X-Git-Url: http://gb7djk.dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;ds=sidebyside;f=perl%2FDXCommandmode.pm;h=474d2c9c90d58ac1f8090ff3c75fd906650e8d90;hb=1cf4bd14be226274d5deb05da8480ab91a5dac52;hp=fb2957da39da7798035ca96890ae87faebb138a7;hpb=56b610b0ed32b6d10122bca7554ce7a11251cdaa;p=spider.git

diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm
index fb2957da..474d2c9c 100644
--- a/perl/DXCommandmode.pm
+++ b/perl/DXCommandmode.pm
@@ -9,73 +9,124 @@
 
 package DXCommandmode;
 
+@ISA = qw(DXChannel);
+
 use DXUtil;
 use DXChannel;
 use DXUser;
-use DXM;
 use DXVars;
+use DXDebug;
+
+use strict;
+
+#use vars qw( %Cache $last_dir_mtime @cmd);
+my %Cache = ();                  # cache of dynamically loaded routine's mod times
+my $last_dir_mtime = 0;          # the last time one of the cmd dirs was modified
+my @cmd = undef;                 # a list of commands+path pairs (in alphabetical order)
+
+#
+# obtain a new connection this is derived from dxchannel
+#
 
-$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)
+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
 # new (or nearly new and slacking) user.
 
-sub user_start
+sub start
 { 
-  my $self = shift;
+  my ($self, $line) = @_;
   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);
+  my $name = $user->{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} = 10;                # a bit of room for further expansion, passwords etc
-  $self->{priv} = 0;                  # set the connection priv to 0 - can be upgraded later
+  $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;
+
 }
 
 #
 # 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 any nasty characters like $@%&|. and double // etc.
-  $cmd =~ s/[\%\@\$\&\|\.\`\~]//og;
-  $cmd =~ s|//|/|og;
+  # strip out //
+  $cmdline =~ s|//|/|og;
   
-  # split the command up into parts
-  my @parts = split |[/\b]+|, $cmd;
+  # 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
 {
+  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);
+	}
+  }
 }
 
 #
 # finish up a user context
 #
-sub user_finish
+sub finish
 {
 
 }
@@ -88,24 +139,48 @@ 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
-#
+# 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
+  }
+}
 
-sub scan_cmd_dirs
+# gimme all the users
+sub get_all
 {
-  my $self = shift;
+  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
+}  
 
 #
 # the persistant execution of things from the command directories
@@ -117,8 +192,6 @@ sub scan_cmd_dirs
 #
 
 #require Devel::Symdump;  
-use strict;
-use vars '%Cache';
 
 sub valid_package_name {
   my($string) = @_;
@@ -128,8 +201,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
@@ -138,7 +211,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};
@@ -147,11 +220,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;
+  my $filename = "$path/$cmdname.pl";
+  my $mtime = -M $filename;
+  
+  # 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,
@@ -160,33 +237,44 @@ 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 = <FH>;
 	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; }};
+	if (isdbg('eval')) {
+	  my @list = split /\n/, $eval;
+	  my $line;
+	  foreach (@list) {
+	    dbg('eval', $_, "\n");
+	  }
+	}
+	#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 unless $delete;
+	$Cache{$package}{mtime} = $mtime;
   }
-
-  @r = eval {$package->handler;};
+  
+  my @r;
+  my $c = qq{ \@r = \$self->$package(\@_); };
+  dbg('eval', "cluster cmd = $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