From: djk Date: Fri, 19 Jun 1998 21:20:30 +0000 (+0000) Subject: sorted out inheritance X-Git-Tag: SPIDER_1_5~54 X-Git-Url: http://www.dxcluster.org/gitweb/gitweb.cgi?p=spider.git;a=commitdiff_plain;h=0121434f428d8e7d1f31a9d69a4ee250b952b468 sorted out inheritance fixed dynamic executor (well it works) added some commands --- diff --git a/cmd/bye b/cmd/bye new file mode 100644 index 00000000..7e8fd9bf --- /dev/null +++ b/cmd/bye @@ -0,0 +1,7 @@ +# +# the bye command +# + +my $self = shift; +$self->state('bye'); +return (1); diff --git a/cmd/set/qra b/cmd/set/qra new file mode 100644 index 00000000..2237b4ea --- /dev/null +++ b/cmd/set/qra @@ -0,0 +1,6 @@ +# +# set the qra locator field +# +my ($self, $args) = @_; +my $user = $self->user; +return (1, "qra locator is now ", $user->qra($args)); diff --git a/cmd/set/qth b/cmd/set/qth new file mode 100644 index 00000000..c54a3289 --- /dev/null +++ b/cmd/set/qth @@ -0,0 +1,6 @@ +# +# set the qth field +# +my ($self, $args) = @_; +my $user = $self->user; +return (1, "qth is now ", $user->qth($args)); diff --git a/cmd/show/user b/cmd/show/user new file mode 100644 index 00000000..21b3c895 --- /dev/null +++ b/cmd/show/user @@ -0,0 +1,15 @@ +# +# show either the current user or a nominated set +# +my $self = shift; +my @set = split; # the list of users you want listings (may be null) + +@set = ($self->call) if !@set; # my call if no args + +my ($call, $field); +my @fields = DXUser->fields(); +foreach $call (@set) { + my $user = DXUser->get($call); +} + + diff --git a/cmd/shutdown b/cmd/shutdown new file mode 100644 index 00000000..bee8a388 --- /dev/null +++ b/cmd/shutdown @@ -0,0 +1,4 @@ +# +# the shutdown command +# +&main::cease(); diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index 9ba985a6..093bfb00 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -25,15 +25,25 @@ # package DXChannel; -require Exporter; -@ISA = qw(DXCommandmode DXProt Exporter); - use Msg; use DXUtil; use DXM; %channels = undef; +%valid = ( + call => 'Callsign', + conn => 'Msg Connection ref', + user => 'DXUser ref', + t => 'Time', + priv => 'Privilege', + state => 'Current State', + oldstate => 'Last State', + list => 'Dependant DXChannels list', + name => 'User Name', +); + + # create a new connection object [$obj = DXChannel->new($call, $msg_conn_obj, $user_obj)] sub new { @@ -173,5 +183,18 @@ sub state print "Db $self->{call} channel state $self->{oldstate} -> $self->{state}\n" if $main::debug; } +# various access routines +sub AUTOLOAD +{ + my $self = shift; + my $name = $AUTOLOAD; + + return if $name =~ /::DESTROY$/; + $name =~ s/.*:://o; + + die "Non-existant field '$AUTOLOAD'" if !$valid{$name}; + @_ ? $self->{$name} = shift : $self->{$name} ; +} + 1; __END__; diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index ae016cc6..d8e1ac10 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -9,12 +9,16 @@ package DXCommandmode; +@ISA = qw(DXChannel); + use DXUtil; use DXChannel; use DXUser; -use DXM; use DXVars; +use strict; +use vars qw( %Cache $last_dir_mtime @cmd); + $last_dir_mtime = 0; # the last time one of the cmd dirs was modified @cmd = undef; # a list of commands+path pairs (in alphabetical order) @@ -22,15 +26,13 @@ $last_dir_mtime = 0; # the last time one of the cmd dirs was modified # possibly some other messages asking you to set various things up if you are # new (or nearly new and slacking) user. -sub user_start +sub start { my $self = shift; my $user = $self->{user}; my $call = $self->{call}; my $name = $self->{name}; $name = $call if !defined $name; - $self->{normal} = \&user_normal; # rfu for now - $self->{finish} = \&user_finish; $self->msg('l2',$name); $self->send_file($main::motd) if (-e $main::motd); $self->msg('pr', $call); @@ -41,40 +43,50 @@ sub user_start # # This is the normal command prompt driver # -sub user_normal +sub normal { my $self = shift; my $user = $self->{user}; my $call = $self->{call}; - my $cmd = shift; + my $cmdline = shift; - # read in the list of valid commands, note that the commands themselves are cached elsewhere - scan_cmd_dirs if (!defined %cmd); + # strip out // + $cmdline =~ s|//|/|og; - # strip out any nasty characters like $@%&|. and double // etc. - $cmd =~ s/[%\@\$&\\.`~]//og; - $cmd =~ s|//|/|og; - - # split the command up into parts - my @part = split /[\/\b]+/, $cmd; - - # the bye command - temporary probably - if ($part[0] =~ /^b/io) { - $self->user_finish(); - $self->state('bye'); - return; + # split the command line up into parts, the first part is the command + my ($cmd, $args) = $cmdline =~ /^([\w\/]+)\s*(.*)/o; + + if ($cmd) { + + # first expand out the entry to a command + $cmd = search($cmd); + + my @ans = $self->eval_file($main::localcmd, $cmd, $args); + @ans = $self->eval_file($main::cmd, $cmd, $args) if !$ans[0]; + if ($ans[0]) { + shift @ans; + $self->send(@ans) if @ans > 0; + } else { + shift @ans; + if (@ans > 0) { + $self->msg('e2', @ans); + } else { + $self->msg('e1'); + } + } + } else { + $self->msg('e1'); } - - # first expand out the entry to a command, note that I will accept - # anything in any case with any (reasonable) seperator - $self->prompt(); + + # send a prompt only if we are in a prompt state + $self->prompt() if $self->{state} =~ /^prompt/o; } # # This is called from inside the main cluster processing loop and is used # for despatching commands that are doing some long processing job # -sub user_process +sub process { } @@ -82,7 +94,7 @@ sub user_process # # finish up a user context # -sub user_finish +sub finish { } @@ -95,24 +107,18 @@ sub prompt { my $self = shift; my $call = $self->{call}; - $self->msg('pr', $call); + DXChannel::msg($self, 'pr', $call); } # -# scan the command directories to see if things have changed -# -# If they have remake the command list -# -# There are two command directories a) the standard one and b) the local one -# The local one overides the standard one +# search for the command in the cache of short->long form commands # -sub scan_cmd_dirs +sub search { - my $self = shift; - - -} + my $short_cmd = shift; + return $short_cmd; # just return it for now +} # # the persistant execution of things from the command directories @@ -124,8 +130,6 @@ sub scan_cmd_dirs # #require Devel::Symdump; -use strict; -use vars '%Cache'; sub valid_package_name { my($string) = @_; @@ -135,8 +139,8 @@ sub valid_package_name { $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg; #Dress it up as a real package name - $string =~ s|/|::|g; - return "DXEmbed" . $string; + $string =~ s|/|_|g; + return "Emb_" . $string; } #borrowed from Safe.pm @@ -145,7 +149,7 @@ sub delete_package { my ($stem, $leaf); no strict 'refs'; - $pkg = "main::$pkg\::"; # expand to full symbol table name + $pkg = "DXChannel::$pkg\::"; # expand to full symbol table name ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; my $stem_symtab = *{$stem}{HASH}; @@ -154,11 +158,15 @@ sub delete_package { } sub eval_file { - my($self, $path, $cmdname) = @_; + my $self = shift; + my $path = shift; + my $cmdname = shift; my $package = valid_package_name($cmdname); my $filename = "$path/$cmdname"; my $mtime = -M $filename; - my @r; + + # return if we can't find it + return (0, DXM::msg('e1')) if !defined $mtime; if(defined $Cache{$package}{mtime} && $Cache{$package}{mtime } <= $mtime) { #we have compiled this subroutine already, @@ -167,33 +175,37 @@ sub eval_file { ; } else { local *FH; - open FH, $filename or die "open '$filename' $!"; + if (!open FH, $filename) { + return (0, "Syserr: can't open '$filename' $!"); + }; local($/) = undef; my $sub = ; close FH; #wrap the code into a subroutine inside our unique package - my $eval = qq{package $package; sub handler { $sub; }}; + my $eval = qq{package DXChannel; sub $package { $sub; }}; + print "eval $eval\n"; { #hide our variables within this block my($filename,$mtime,$package,$sub); eval $eval; } if ($@) { - $self->send("Eval err $@ on $package"); delete_package($package); - return undef; + return (0, "Syserr: Eval err $@ on $package"); } #cache it unless we're cleaning out each time $Cache{$package}{mtime} = $mtime; } - - @r = eval {$package->handler;}; + + my @r; + my $c = qq{ \@r = \$self->$package(\@_); }; + print "c = $c\n"; + eval $c; ; if ($@) { - $self->send("Eval err $@ on cached $package"); delete_package($package); - return undef; + return (0, "Syserr: Eval err $@ on cached $package"); } #take a look if you want diff --git a/perl/DXM.pm b/perl/DXM.pm index 41c2bbff..435e32f9 100644 --- a/perl/DXM.pm +++ b/perl/DXM.pm @@ -24,6 +24,8 @@ require Exporter; l1 => 'Sorry $_[0], you are already logged on on another channel', l2 => 'Hello $_[0], this is $main::mycall located in $main::myqth', pr => '$_[0] de $main::mycall $main::cldate $main::ztime >', + e1 => 'Invalid command', + e2 => 'Error: $_[0]', ); sub msg diff --git a/perl/DXProt.pm b/perl/DXProt.pm index b21a4b58..f0a0a3b2 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -9,6 +9,8 @@ package DXProt; +@ISA = qw(DXChannel); + use DXUtil; use DXChannel; use DXUser; @@ -17,17 +19,15 @@ use DXM; # this is how a pc connection starts (for an incoming connection) # issue a PC38 followed by a PC18, then wait for a PC20 (remembering # all the crap that comes between). -sub pc_start +sub start { my $self = shift; - $self->{normal} = \&pc_normal; - $self->{finish} = \&pc_finish; } # # This is the normal pcxx despatcher # -sub pc_normal +sub normal { } @@ -36,7 +36,7 @@ sub pc_normal # This is called from inside the main cluster processing loop and is used # for despatching commands that are doing some long processing job # -sub pc_process +sub process { } @@ -44,7 +44,7 @@ sub pc_process # # finish up a pc context # -sub pc_clean +sub finish { } diff --git a/perl/DXUser.pm b/perl/DXUser.pm index 7ce853c6..101340c8 100644 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@ -29,12 +29,24 @@ $filename = undef; qra => 'Locator', email => 'E-mail Address', priv => 'Privilege Level', - sort => 'Type of User', lastin => 'Last Time in', passwd => 'Password', - addr => 'Full Address' + addr => 'Full Address', + 'sort' => 'Type of User', # A - ak1a, U - User, S - spider cluster, B - BBS ); +sub AUTOLOAD +{ + my $self = shift; + my $name = $AUTOLOAD; + + return if $name =~ /::DESTROY$/; + $name =~ s/.*:://o; + + die "Non-existant field '$AUTOLOAD'" if !$valid{$name}; + @_ ? $self->{$name} = shift : $self->{$name} ; +} + # # initialise the system # @@ -125,13 +137,13 @@ sub elements } # -# return a prompt together with the existing value +# return a prompt for a field # sub prompt { my ($self, $ele) = @_; - return "$valid{$ele} [$self->{$ele}]"; + return $valid{$ele}; } # @@ -167,5 +179,12 @@ sub enter } return 0; } + +# some variable accessors +sub sort +{ + my $self = shift; + @_ ? $self->{sort} = shift : $self->{sort} ; +} 1; __END__ diff --git a/perl/cluster.pl b/perl/cluster.pl index 2f96af88..8da9fe00 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -33,11 +33,7 @@ sub disconnect return if !defined $dxchan; my $user = $dxchan->{user}; my $conn = $dxchan->{conn}; - if ($user->{sort} eq 'A') { # and here (when I find out how to write it!) - $dxchan->pc_finish(); - } else { - $dxchan->user_finish(); - } + $dxchan->finish(); $user->close() if defined $user; $conn->disconnect() if defined $conn; $dxchan->del(); @@ -59,7 +55,11 @@ sub rec my ($sort, $call, $line) = $msg =~ /^(\w)(\S+)\|(.*)$/; my $user = DXUser->get($call); $user = DXUser->new($call) if !defined $user; - $dxchan = DXChannel->new($call, $conn, $user); + $user->sort('U') if (!$user->sort()); + my $sort = $user->sort(); + $dxchan = DXCommandmode->new($call, $conn, $user) if ($sort eq 'U'); + $dxchan = DXProt->new($call, $conn, $user) if ($sort eq 'A'); + die "Invalid sort of user on $call = $sort" if !$dxchan; } # queue the message and the channel object for later processing @@ -102,21 +102,12 @@ sub process_inqueue print "<- $sort $call $line\n"; # handle A records - my $user = $dxchan->{user}; + my $user = $dxchan->user; if ($sort eq 'A') { - $user->{sort} = 'U' if !defined $user->{sort}; - if ($user->{sort} eq 'A') { - $dxchan->pc_start($line); - } else { - $dxchan->user_start($line); - } + $dxchan->start($line); } elsif ($sort eq 'D') { die "\$user not defined for $call" if !defined $user; - if ($user->{sort} eq 'A') { # we will have a symbolic ref to a proc here - $dxchan->pc_normal($line); - } else { - $dxchan->user_normal($line); - } + $dxchan->normal($line); disconnect($dxchan) if ($dxchan->{state} eq 'bye'); } elsif ($sort eq 'Z') { disconnect($dxchan); @@ -158,7 +149,7 @@ for (;;) { $ztime = &ztime(); } process_inqueue(); # read in lines from the input queue and despatch them - DXCommandmode::user_process(); # process ongoing command mode stuff - DXProt::pc_process(); # process ongoing ak1a pcxx stuff + DXCommandmode::process(); # process ongoing command mode stuff + DXProt::process(); # process ongoing ak1a pcxx stuff }