changed the command mode subs thing to use anonymous subs

allow locally connect clusters to appear in the node list even if they
don't issue PC19s (but do issue PC16s)

diff --git a/Changes b/Changes
index 6b84bee72c0b4bb6dcaa3aa68398fcd337ac9c58..c53af39d05df3a068ac14a6ddf1a17ecdd2dd70a 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,3 +1,8 @@
+03Nov99=======================================================================
+1. Simplified command caching so it uses anonymous subroutines, you should
+also get error messages back on the console now when developing.
+2. Allow locally connected AK1A clusters that for some obscure reason don't
+issue PC19s to still appear as connected and allow them to acquire users.
 31Oct99=======================================================================
 1. updated Minimuf.pm and show/muf.pl to the fixed versions sent to me by
 Steve Franke K9AN. 

diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm
index f2ba37454457b2573fc6088be8fa3e0388cf6a2f..12c84c009d7310d1ac7b57f163caca3f62153aaa 100644 (file)
--- a/perl/DXCommandmode.pm
+++ b/perl/DXCommandmode.pm
@@ -195,7 +195,7 @@ sub run_cmd
                dbg('eval', "stored func cmd = $c\n");
                eval  $c;
                if ($@) {
-                       return (1, "Syserr: Eval err $errstr on stored func $self->{func}");
+                       return ("Syserr: Eval err $errstr on stored func $self->{func}", $@);
                }
        } else {
 
@@ -232,31 +232,25 @@ sub run_cmd
                                
                                if ($package) {
                                        dbg('command', "package: $package");
-                                       
-                                       my $c = qq{ \@ans = $package(\$self, \$args) };
-                                       dbg('eval', "cluster cmd = $c\n");
-                                       eval  $c;
-                                       if ($@) {
-                                               @ans = (0, "Syserr: Eval err cached $package\n$@");
+                                       my $c;
+                                       unless (exists $Cache{$package}->{sub}) {
+                                               $c = eval $Cache{$package}->{eval};
+                                               if ($@) {
+                                                       return ("Syserr: Syntax error in $package", $@);
+                                               }
+                                               $Cache{$package}->{sub} = $c;
                                        }
+                                       $c = $Cache{$package}->{sub};
+                                       @ans = &{$c}($self, $args);
                                }
                        } else {
                                dbg('command', "cmd: $cmd not found");
-                               @ans = (0);
+                               return ($self->msg('e1'));
                        }
                }
        }
        
-       if ($ans[0]) {
-               shift @ans;
-       } else {
-               shift @ans;
-               if (@ans > 0) {
-                       unshift @ans, $self->msg('e2');
-               } else {
-                       @ans = $self->msg('e1');
-               }
-       }
+       shift @ans;
        return (@ans);
 }
 
@@ -443,22 +437,7 @@ sub valid_package_name {
        
        #Dress it up as a real package name
        $string =~ s/\//_/og;
-       return "Emb_" . $string;
-}
-
-#borrowed from Safe.pm
-sub delete_package {
-       my $pkg = shift;
-       my ($stem, $leaf);
-       
-       no strict 'refs';
-       $pkg = "DXCommandmode::$pkg\::"; # expand to full symbol table name
-       ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
-       
-       if ($stem && $leaf) {
-               my $stem_symtab = *{$stem}{HASH};
-               delete $stem_symtab->{$leaf};
-       }
+       return $string;
 }
 
 # find a cmd reference
@@ -502,13 +481,12 @@ sub find_cmd_name {
                return undef;
        }
        
-       if(defined $Cache{$package}{mtime} && $Cache{$package}{mtime } <= $mtime) {
+       if(defined $Cache{$package}->{mtime} &&$Cache{$package}->{mtime} <= $mtime) {
                #we have compiled this subroutine already,
                #it has not been updated on disk, nothing left to do
                #print STDERR "already compiled $package->handler\n";
                ;
        } else {
-               delete_package($package) if defined $Cache{$package}{mtime};
                
                my $fh = new IO::File;
                if (!open $fh, $filename) {
@@ -520,7 +498,7 @@ sub find_cmd_name {
                close $fh;
                
                #wrap the code into a subroutine inside our unique package
-               my $eval = qq{ sub $package { $sub } };
+               my $eval = qq( sub { $sub } );
                
                if (isdbg('eval')) {
                        my @list = split /\n/, $eval;
@@ -530,25 +508,9 @@ sub find_cmd_name {
                        }
                }
                
-               {
-                       #hide our variables within this block
-                       my($filename,$mtime,$package,$sub);
-                       eval $eval;
-               }
-               
-               if ($@) {
-                       print "\$\@ = $@";
-                       $errstr = $@;
-                       delete_package($package);
-               } else {
-                       #cache it unless we're cleaning out each time
-                       $Cache{$package}{'mtime'} = $mtime;
-               }
+               $Cache{$package} = {mtime => $mtime, eval => $eval };
        }
-       
-       #print Devel::Symdump->rnew($package)->as_string, $/;
-       $package = "DXCommandmode::$package" if $package;
-       $package = undef if $errstr;
+
        return $package;
 }
 

diff --git a/perl/DXProt.pm b/perl/DXProt.pm
index ee8c4aa9ef4d03e97fdfe0894e431f036ccb912c..32d5e3b381933292e90cd502f7dc569773e86c59 100644 (file)
--- a/perl/DXProt.pm
+++ b/perl/DXProt.pm
@@ -313,20 +313,24 @@ sub normal
                
                if ($pcno == 16) {              # add a user
                        my $node = DXCluster->get_exact($field[1]); 
+                       my $dxchan;
+                       if (!$node && ($dxchan = DXChannel->get($field[1]))) {
+                               # add it to the node table if it isn't present and it's
+                               # connected locally
+                               $node = DXNode->new($dxchan, $field[1], 0, 1, 5400);
+                       }
                        return unless $node; # ignore if havn't seen a PC19 for this one yet
                        return unless $node->isa('DXNode');
                        if ($node->dxchan != $self) {
                                dbg('chan', "LOOP: $field[1] came in on wrong channel");
                                return;
                        }
-                       my $dxchan;
                        if (($dxchan = DXChannel->get($field[1])) && $dxchan != $self) {
                                dbg('chan', "LOOP: $field[1] connected locally");
                                return;
                        }
                        my $i;
-                       
-                       
+                                               
                        for ($i = 2; $i < $#field; $i++) {
                                my ($call, $confmode, $here) = $field[$i] =~ /^(\S+) (\S) (\d)/o;
                                next if !$call || length $call < 3 || length $call > 8;

diff --git a/perl/cluster.pl b/perl/cluster.pl
index ceb099ca7eb4f6b64977447e6a800d7c5be0c1e6..308b1d90b987104618df84182a10399b6f94ea38 100755 (executable)
--- a/perl/cluster.pl
+++ b/perl/cluster.pl
@@ -67,7 +67,7 @@ package main;
 
 @inqueue = ();                                 # the main input queue, an array of hashes
 $systime = 0;                                  # the time now (in seconds)
-$version = "1.33";                             # the version no of the software
+$version = "1.34";                             # the version no of the software
 $starttime = 0;                 # the starting time of the cluster   
 $lockfn = "cluster.lock";       # lock file name