X-Git-Url: http://www.dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXCommandmode.pm;h=928981abd0effd850d4d301db6ccc41673c9726a;hb=2546ef0cfaaca39e65985e414258071a636979af;hp=6a3603abd306f75b1260d243ae80340732026143;hpb=6b6a8002929017b6d4217f68fa492a2d728ee1fe;p=spider.git

diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm
index 6a3603ab..928981ab 100644
--- a/perl/DXCommandmode.pm
+++ b/perl/DXCommandmode.pm
@@ -16,12 +16,25 @@ use DXChannel;
 use DXUser;
 use DXVars;
 use DXDebug;
+use DXM;
+use Carp;
 
 use strict;
-use vars qw( %Cache $last_dir_mtime @cmd);
+use vars qw(%Cache %cmd_cache);
 
-$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)
+%Cache = ();                  # cache of dynamically loaded routine's mod times
+%cmd_cache = ();            # cache of short names
+
+#
+# obtain a new connection this is derived from dxchannel
+#
+
+sub new 
+{
+  my $self = DXChannel::alloc(@_);
+  $self->{sort} = 'U';   # in absence of how to find out what sort of an object I am
+  return $self;
+}
 
 # this is how a a connection starts, you get a hello message and the motd with
 # possibly some other messages asking you to set various things up if you are
@@ -32,16 +45,30 @@ sub start
   my ($self, $line) = @_;
   my $user = $self->{user};
   my $call = $self->{call};
-  my $name = $self->{name};
-  $name = $call if !defined $name;
+  my $name = $user->{name};
 
-  $self->msg('l2',$name);
+  $self->{name} = $name ? $name : $call;
+  $self->msg('l2',$self->{name});
   $self->send_file($main::motd) if (-e $main::motd);
   $self->msg('pr', $call);
   $self->state('prompt');                  # a bit of room for further expansion, passwords etc
   $self->{priv} = $user->priv;
   $self->{priv} = 0 if $line =~ /^(ax|te)/;     # set the connection priv to 0 - can be upgraded later
   $self->{consort} = $line;                # save the connection type
+
+  # set some necessary flags on the user if they are connecting
+  $self->{wwv} = $self->{talk} = $self->{ann} = $self->{here} = $self->{dx} = 1;
+  $self->prompt() if $self->{state} =~ /^prompt/o;
+  
+  # add yourself to the database
+  my $node = DXNode->get($main::mycall) or die "$main::mycall not allocated in DXNode database";
+  my $cuser = DXNodeuser->new($self, $node, $call, 0, 1);
+  $node->dxchan($self) if $call eq $main::myalias;       # send all output for mycall to myalias
+  
+  # issue a pc16 to everybody interested
+  my $nchan = DXChannel->get($main::mycall);
+  my @pc16 = DXProt::pc16($nchan, $cuser);
+  DXProt::broadcast_ak1a(@pc16);
 }
 
 #
@@ -52,7 +79,7 @@ sub normal
   my $self = shift;
   my $user = $self->{user};
   my $call = $self->{call};
-  my $cmdline = shift; 
+  my $cmdline = shift;
 
   # strip out //
   $cmdline =~ s|//|/|og;
@@ -61,12 +88,15 @@ sub normal
   my ($cmd, $args) = $cmdline =~ /^([\w\/]+)\s*(.*)/o;
 
   if ($cmd) {
-
+    
+	my ($path, $fcmd);
+   
     # first expand out the entry to a command
-    $cmd = search($cmd);
+    ($path, $fcmd) = search($main::localcmd, $cmd, "pl");
+    ($path, $fcmd) = search($main::cmd, $cmd, "pl") if !$path || !$fcmd;
 
-    my @ans = $self->eval_file($main::localcmd, $cmd, $args);
-	@ans = $self->eval_file($main::cmd, $cmd, $args) if !$ans[0];
+    my @ans = $self->eval_file($path, $fcmd, $args) if $path && $fcmd;
+#	@ans = $self->eval_file($main::cmd, $cmd, $args) if !$ans[0];
 	if ($ans[0]) {
       shift @ans;
 	  $self->send(@ans) if @ans > 0;
@@ -92,7 +122,19 @@ sub normal
 #
 sub process
 {
+  my $t = time;
+  my @chan = DXChannel->get_all();
+  my $chan;
+  
+  foreach $chan (@chan) {
+    next if $chan->sort ne 'U';  
 
+    # send a prompt if no activity out on this channel
+    if ($t >= $chan->t + $main::user_interval) {
+      $chan->prompt() if $chan->{state} =~ /^prompt/o;
+	  $chan->t($t);
+	}
+  }
 }
 
 #
@@ -100,7 +142,21 @@ sub process
 #
 sub finish
 {
+  my $self = shift;
+  my $call = $self->call;
 
+  if ($call eq $main::myalias) {   # unset the channel if it is us really
+    my $node = DXNode->get($main::mycall);
+	$node->{dxchan} = 0;
+  }
+  my $ref = DXNodeuser->get($call);
+
+  # issue a pc17 to everybody interested
+  my $nchan = DXChannel->get($main::mycall);
+  my $pc17 = $nchan->pc17($self);
+  DXProt::broadcast_ak1a($pc17);
+  
+  $ref->del() if $ref;
 }
 
 #
@@ -114,16 +170,99 @@ sub prompt
   DXChannel::msg($self, 'pr', $call);
 }
 
+# broadcast a message to all users [except those mentioned after buffer]
+sub broadcast
+{
+  my $pkg = shift;                # ignored
+  my $s = shift;                  # the line to be rebroadcast
+  my @except = @_;                # to all channels EXCEPT these (dxchannel refs)
+  my @list = DXChannel->get_all();   # just in case we are called from some funny object
+  my ($chan, $except);
+  
+L: foreach $chan (@list) {
+     next if !$chan->sort eq 'U';  # only interested in user channels  
+	 foreach $except (@except) {
+	   next L if $except == $chan;  # ignore channels in the 'except' list
+	 }
+	 chan->send($s);              # send it
+  }
+}
+
+# gimme all the users
+sub get_all
+{
+  my @list = DXChannel->get_all();
+  my $ref;
+  my @out;
+  foreach $ref (@list) {
+    push @out, $ref if $ref->sort eq 'U';
+  }
+  return @out;
+}
+
 #
 # search for the command in the cache of short->long form commands
 #
 
 sub search
 {
-  my $short_cmd = shift;
-  return $short_cmd;    # just return it for now
+  my ($path, $short_cmd, $suffix) = @_;
+  my ($apath, $acmd);
+
+  # commands are lower case
+  $short_cmd = lc $short_cmd;
+  dbg('command', "command: $path $short_cmd\n");
+  
+  # return immediately if we have it
+  my ($apath, $acmd) = split ',', $cmd_cache{$short_cmd};
+  if ($apath && $acmd) {
+    dbg('command', "cached $short_cmd = ($apath, $acmd)\n");
+    return ($apath, $acmd) if $apath;
+  }
+  
+  # if not guess
+  my @parts = split '/', $short_cmd;
+  my $dirfn;
+  my $curdir = $path;
+  my $p;
+  my $i;
+  
+  for ($i = 0; $i < @parts; $i++) {
+    my  $p = $parts[$i];
+	opendir(D, $curdir) or confess "can't open $curdir $!";
+	my @ls = readdir D;
+	closedir D;
+	my $l;
+	foreach $l (sort @ls) {
+	  next if $l =~ /^\./;
+      if ($i < $#parts) {            # we are dealing with directories
+        if ((-d "$curdir/$l") && $p eq substr($l, 0, length $p)) {
+		  dbg('command', "got dir: $curdir/$l\n");
+		  $dirfn .= "$l/";
+		  $curdir .= "/$l";
+		  last;
+		}
+      } else {                       # we are dealing with commands
+		next if !$l =~ /\.$suffix$/;       # only look for .$suffix files
+		if ($p eq substr($l, 0, length $p)) {
+		  $l =~ s/\.$suffix$//;      # remove the suffix
+		  chop $dirfn;               # remove trailing /
+		  $cmd_cache{"$short_cmd"} = join(',', ($path, "$dirfn/$l"));   # cache it
+          dbg('command', "got path: $path cmd: $dirfn/$l\n");
+		  return ($path, "$dirfn/$l"); 
+		}
+	  }
+	}
+  }
+  return ();  
 }  
 
+# clear the command name cache
+sub clear_cmd_cache
+{
+  %cmd_cache = ();
+}
+
 #
 # the persistant execution of things from the command directories
 #
@@ -213,10 +352,10 @@ sub eval_file {
   my @r;
   my $c = qq{ \@r = \$self->$package(\@_); };
   dbg('eval', "cluster cmd = $c\n");
-  eval  $c; ;
+  eval  $c;
   if ($@) {
     delete_package($package);
-	return (0, "Syserr: Eval err $@ on cached $package");
+	return (1, "Syserr: Eval err $@ on cached $package");
   }
 
   #take a look if you want