perl/DXCommandmode.pm

   1 #!/usr/bin/perl
   2 #
   3 # This module impliments the user facing command mode for a dx cluster
   4 #
   5 # Copyright (c) 1998 Dirk Koopman G1TLH
   6 #
   7 # $Id$
   8 #
   9
  10 package DXCommandmode;
  11
  12 @ISA = qw(DXChannel);
  13
  14 use DXUtil;
  15 use DXChannel;
  16 use DXUser;
  17 use DXVars;
  18 use DXDebug;
  19 use DXM;
  20 use Carp;
  21
  22 use strict;
  23 use vars qw(%Cache %cmd_cache);
  24
  25 %Cache = ();                  # cache of dynamically loaded routine's mod times
  26 %cmd_cache = ();            # cache of short names
  27
  28 #
  29 # obtain a new connection this is derived from dxchannel
  30 #
  31
  32 sub new
  33 {
  34   my $self = DXChannel::alloc(@_);
  35   $self->{sort} = 'U';   # in absence of how to find out what sort of an object I am
  36   return $self;
  37 }
  38
  39 # this is how a a connection starts, you get a hello message and the motd with
  40 # possibly some other messages asking you to set various things up if you are
  41 # new (or nearly new and slacking) user.
  42
  43 sub start
  44 {
  45   my ($self, $line) = @_;
  46   my $user = $self->{user};
  47   my $call = $self->{call};
  48   my $name = $user->{name};
  49
  50   $self->{name} = $name ? $name : $call;
  51   $self->msg('l2',$self->{name});
  52   $self->send_file($main::motd) if (-e $main::motd);
  53   $self->msg('pr', $call);
  54   $self->state('prompt');                  # a bit of room for further expansion, passwords etc
  55   $self->{priv} = $user->priv;
  56   $self->{priv} = 0 if $line =~ /^(ax|te)/;     # set the connection priv to 0 - can be upgraded later
  57   $self->{consort} = $line;                # save the connection type
  58
  59   # set some necessary flags on the user if they are connecting
  60   $self->{wwv} = $self->{talk} = $self->{ann} = $self->{here} = $self->{dx} = 1;
  61   $self->prompt() if $self->{state} =~ /^prompt/o;
  62
  63 }
  64
  65 #
  66 # This is the normal command prompt driver
  67 #
  68 sub normal
  69 {
  70   my $self = shift;
  71   my $user = $self->{user};
  72   my $call = $self->{call};
  73   my $cmdline = shift;
  74
  75   # strip out //
  76   $cmdline =~ s|//|/|og;
  77
  78   # split the command line up into parts, the first part is the command
  79   my ($cmd, $args) = $cmdline =~ /^([\w\/]+)\s*(.*)/o;
  80
  81   if ($cmd) {
  82
  83         my ($path, $fcmd);
  84
  85     # first expand out the entry to a command
  86     ($path, $fcmd) = search($main::localcmd, $cmd, "pl");
  87     ($path, $fcmd) = search($main::cmd, $cmd, "pl") if !$path || !$fcmd;
  88
  89     my @ans = $self->eval_file($path, $fcmd, $args) if $path && $fcmd;
  90 #       @ans = $self->eval_file($main::cmd, $cmd, $args) if !$ans[0];
  91         if ($ans[0]) {
  92       shift @ans;
  93           $self->send(@ans) if @ans > 0;
  94         } else {
  95       shift @ans;
  96           if (@ans > 0) {
  97             $self->msg('e2', @ans);
  98           } else {
  99         $self->msg('e1');
 100           }
 101         }
 102   } else {
 103     $self->msg('e1');
 104   }
 105
 106   # send a prompt only if we are in a prompt state
 107   $self->prompt() if $self->{state} =~ /^prompt/o;
 108 }
 109
 110 #
 111 # This is called from inside the main cluster processing loop and is used
 112 # for despatching commands that are doing some long processing job
 113 #
 114 sub process
 115 {
 116   my $t = time;
 117   my @chan = DXChannel->get_all();
 118   my $chan;
 119
 120   foreach $chan (@chan) {
 121     next if $chan->sort ne 'U';
 122
 123     # send a prompt if no activity out on this channel
 124     if ($t >= $chan->t + $main::user_interval) {
 125       $chan->prompt() if $chan->{state} =~ /^prompt/o;
 126           $chan->t($t);
 127         }
 128   }
 129 }
 130
 131 #
 132 # finish up a user context
 133 #
 134 sub finish
 135 {
 136
 137 }
 138
 139 #
 140 # short cut to output a prompt
 141 #
 142
 143 sub prompt
 144 {
 145   my $self = shift;
 146   my $call = $self->{call};
 147   DXChannel::msg($self, 'pr', $call);
 148 }
 149
 150 # broadcast a message to all users [except those mentioned after buffer]
 151 sub broadcast
 152 {
 153   my $pkg = shift;                # ignored
 154   my $s = shift;                  # the line to be rebroadcast
 155   my @except = @_;                # to all channels EXCEPT these (dxchannel refs)
 156   my @list = DXChannel->get_all();   # just in case we are called from some funny object
 157   my ($chan, $except);
 158
 159 L: foreach $chan (@list) {
 160      next if !$chan->sort eq 'U';  # only interested in user channels
 161          foreach $except (@except) {
 162            next L if $except == $chan;  # ignore channels in the 'except' list
 163          }
 164          chan->send($s);              # send it
 165   }
 166 }
 167
 168 # gimme all the users
 169 sub get_all
 170 {
 171   my @list = DXChannel->get_all();
 172   my $ref;
 173   my @out;
 174   foreach $ref (@list) {
 175     push @out, $ref if $ref->sort eq 'U';
 176   }
 177   return @out;
 178 }
 179
 180 #
 181 # search for the command in the cache of short->long form commands
 182 #
 183
 184 sub search
 185 {
 186   my ($path, $short_cmd, $suffix) = @_;
 187   my ($apath, $acmd);
 188
 189   # commands are lower case
 190   $short_cmd = lc $short_cmd;
 191   dbg('command', "command: $path $short_cmd\n");
 192
 193   # return immediately if we have it
 194   my ($apath, $acmd) = split ',', $cmd_cache{$short_cmd};
 195   if ($apath && $acmd) {
 196     dbg('command', "cached $short_cmd = ($apath, $acmd)\n");
 197     return ($apath, $acmd) if $apath;
 198   }
 199
 200   # if not guess
 201   my @parts = split '/', $short_cmd;
 202   my $dirfn;
 203   my $curdir = $path;
 204   my $p;
 205   my $i;
 206
 207   for ($i = 0; $i < @parts; $i++) {
 208     my  $p = $parts[$i];
 209         opendir(D, $curdir) or confess "can't open $curdir $!";
 210         my @ls = readdir D;
 211         closedir D;
 212         my $l;
 213         foreach $l (sort @ls) {
 214           next if $l =~ /^\./;
 215       if ($i < $#parts) {            # we are dealing with directories
 216         if ((-d "$curdir/$l") && $p eq substr($l, 0, length $p)) {
 217                   dbg('command', "got dir: $curdir/$l\n");
 218                   $dirfn .= "$l/";
 219                   $curdir .= "/$l";
 220                   last;
 221                 }
 222       } else {                       # we are dealing with commands
 223                 next if !$l =~ /\.$suffix$/;       # only look for .$suffix files
 224                 if ($p eq substr($l, 0, length $p)) {
 225                   $l =~ s/\.$suffix$//;      # remove the suffix
 226                   chop $dirfn;               # remove trailing /
 227                   $cmd_cache{"$short_cmd"} = join(',', ($path, "$dirfn/$l"));   # cache it
 228           dbg('command', "got path: $path cmd: $dirfn/$l\n");
 229                   return ($path, "$dirfn/$l");
 230                 }
 231           }
 232         }
 233   }
 234   return ();
 235 }
 236
 237 # clear the command name cache
 238 sub clear_cmd_cache
 239 {
 240   %cmd_cache = ();
 241 }
 242
 243 #
 244 # the persistant execution of things from the command directories
 245 #
 246 #
 247 # This allows perl programs to call functions dynamically
 248 #
 249 # This has been nicked directly from the perlembed pages
 250 #
 251
 252 #require Devel::Symdump;
 253
 254 sub valid_package_name {
 255   my($string) = @_;
 256   $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg;
 257
 258   #second pass only for words starting with a digit
 259   $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg;
 260
 261   #Dress it up as a real package name
 262   $string =~ s|/|_|g;
 263   return "Emb_" . $string;
 264 }
 265
 266 #borrowed from Safe.pm
 267 sub delete_package {
 268   my $pkg = shift;
 269   my ($stem, $leaf);
 270
 271   no strict 'refs';
 272   $pkg = "DXChannel::$pkg\::";    # expand to full symbol table name
 273   ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
 274
 275   my $stem_symtab = *{$stem}{HASH};
 276
 277   delete $stem_symtab->{$leaf};
 278 }
 279
 280 sub eval_file {
 281   my $self = shift;
 282   my $path = shift;
 283   my $cmdname = shift;
 284   my $package = valid_package_name($cmdname);
 285   my $filename = "$path/$cmdname.pl";
 286   my $mtime = -M $filename;
 287
 288   # return if we can't find it
 289   return (0, DXM::msg('e1')) if !defined $mtime;
 290
 291   if(defined $Cache{$package}{mtime} && $Cache{$package}{mtime } <= $mtime) {
 292     #we have compiled this subroutine already,
 293         #it has not been updated on disk, nothing left to do
 294         #print STDERR "already compiled $package->handler\n";
 295         ;
 296   } else {
 297         local *FH;
 298         if (!open FH, $filename) {
 299           return (0, "Syserr: can't open '$filename' $!");
 300         };
 301         local($/) = undef;
 302         my $sub = <FH>;
 303         close FH;
 304
 305     #wrap the code into a subroutine inside our unique package
 306         my $eval = qq{package DXChannel; sub $package { $sub; }};
 307         if (isdbg('eval')) {
 308           my @list = split /\n/, $eval;
 309           my $line;
 310           foreach (@list) {
 311             dbg('eval', $_, "\n");
 312           }
 313         }
 314         #print "eval $eval\n";
 315         {
 316           #hide our variables within this block
 317           my($filename,$mtime,$package,$sub);
 318           eval $eval;
 319         }
 320         if ($@) {
 321           delete_package($package);
 322           return (0, "Syserr: Eval err $@ on $package");
 323         }
 324
 325         #cache it unless we're cleaning out each time
 326         $Cache{$package}{mtime} = $mtime;
 327   }
 328
 329   my @r;
 330   my $c = qq{ \@r = \$self->$package(\@_); };
 331   dbg('eval', "cluster cmd = $c\n");
 332   eval  $c; ;
 333   if ($@) {
 334     delete_package($package);
 335         return (0, "Syserr: Eval err $@ on cached $package");
 336   }
 337
 338   #take a look if you want
 339   #print Devel::Symdump->rnew($package)->as_string, $/;
 340   return @r;
 341 }
 342
 343 1;
 344 __END__