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 CmdAlias;
  21 use FileHandle;
  22 use Carp;
  23
  24 use strict;
  25 use vars qw(%Cache %cmd_cache $errstr %aliases);
  26
  27 %Cache = ();                  # cache of dynamically loaded routine's mod times
  28 %cmd_cache = ();            # cache of short names
  29 $errstr = ();                # error string from eval
  30 %aliases = ();              # aliases for (parts of) commands
  31
  32 #
  33 # obtain a new connection this is derived from dxchannel
  34 #
  35
  36 sub new
  37 {
  38   my $self = DXChannel::alloc(@_);
  39   $self->{sort} = 'U';   # in absence of how to find out what sort of an object I am
  40   return $self;
  41 }
  42
  43 # this is how a a connection starts, you get a hello message and the motd with
  44 # possibly some other messages asking you to set various things up if you are
  45 # new (or nearly new and slacking) user.
  46
  47 sub start
  48 {
  49   my ($self, $line) = @_;
  50   my $user = $self->{user};
  51   my $call = $self->{call};
  52   my $name = $user->{name};
  53
  54   $self->{name} = $name ? $name : $call;
  55   $self->send($self->msg('l2',$self->{name}));
  56   $self->send_file($main::motd) if (-e $main::motd);
  57   $self->send($self->msg('pr', $call));
  58   $self->state('prompt');                  # a bit of room for further expansion, passwords etc
  59   $self->{priv} = $user->priv;
  60   $self->{lang} = $user->lang;
  61   $self->{priv} = 0 if $line =~ /^(ax|te)/;     # set the connection priv to 0 - can be upgraded later
  62   $self->{consort} = $line;                # save the connection type
  63
  64   # set some necessary flags on the user if they are connecting
  65   $self->{wwv} = $self->{talk} = $self->{ann} = $self->{here} = $self->{dx} = 1;
  66 #  $self->prompt() if $self->{state} =~ /^prompt/o;
  67
  68   # add yourself to the database
  69   my $node = DXNode->get($main::mycall) or die "$main::mycall not allocated in DXNode database";
  70   my $cuser = DXNodeuser->new($self, $node, $call, 0, 1);
  71   $node->dxchan($self) if $call eq $main::myalias;       # send all output for mycall to myalias
  72
  73   # issue a pc16 to everybody interested
  74   my $nchan = DXChannel->get($main::mycall);
  75   my @pc16 = DXProt::pc16($nchan, $cuser);
  76   DXProt::broadcast_ak1a(@pc16);
  77 }
  78
  79 #
  80 # This is the normal command prompt driver
  81 #
  82 sub normal
  83 {
  84   my $self = shift;
  85   my $user = $self->{user};
  86   my $call = $self->{call};
  87   my $cmdline = shift;
  88   my @ans;
  89
  90   # are we in stored state?
  91   if ($self->{func}) {
  92     my $c = qq{ \@ans = $self->{func}(\$self, \$cmdline) };
  93     dbg('eval', "stored func cmd = $c\n");
  94     eval  $c;
  95     if ($@) {
  96       return (1, "Syserr: Eval err $errstr on stored func $self->{func}");
  97     }
  98   } else {
  99
 100     # special case only \n input => " "
 101     if ($cmdline eq " ") {
 102           $self->prompt();
 103           return;
 104         }
 105
 106     # strip out //
 107     $cmdline =~ s|//|/|og;
 108
 109     # split the command line up into parts, the first part is the command
 110     my ($cmd, $args) = $cmdline =~ /^([\w\/]+)\s*(.*)/o;
 111
 112     if ($cmd) {
 113
 114           my ($path, $fcmd);
 115
 116           # alias it if possible
 117           my $acmd = CmdAlias::get_cmd($cmd);
 118           if ($acmd) {
 119             ($cmd, $args) = "$acmd $args" =~ /^([\w\/]+)\s*(.*)/o;
 120           }
 121
 122       # first expand out the entry to a command
 123           ($path, $fcmd) = search($main::localcmd, $cmd, "pl");
 124           ($path, $fcmd) = search($main::cmd, $cmd, "pl") if !$path || !$fcmd;
 125
 126       my $package = find_cmd_name($path, $fcmd);
 127           @ans = (0) if !$package ;
 128
 129       if ($package) {
 130             my $c = qq{ \@ans = $package(\$self, \$args) };
 131             dbg('eval', "cluster cmd = $c\n");
 132             eval  $c;
 133             if ($@) {
 134                   @ans = (0, "Syserr: Eval err cached $package\n$@");
 135         }
 136           }
 137         }
 138   }
 139
 140 #    my @ans = $self->eval_file($path, $fcmd, $args) if $path && $fcmd;
 141 #       @ans = $self->eval_file($main::cmd, $cmd, $args) if !$ans[0];
 142   if ($ans[0]) {
 143     shift @ans;
 144         $self->send(@ans) if @ans > 0;
 145   } else {
 146     shift @ans;
 147         if (@ans > 0) {
 148           $self->send($self->msg('e2'), @ans);
 149         } else {
 150       $self->send($self->msg('e1'));
 151         }
 152   }
 153
 154   # send a prompt only if we are in a prompt state
 155   $self->prompt() if $self->{state} =~ /^prompt/o;
 156 }
 157
 158 #
 159 # This is called from inside the main cluster processing loop and is used
 160 # for despatching commands that are doing some long processing job
 161 #
 162 sub process
 163 {
 164   my $t = time;
 165   my @chan = DXChannel->get_all();
 166   my $chan;
 167
 168   foreach $chan (@chan) {
 169     next if $chan->sort ne 'U';
 170
 171     # send a prompt if no activity out on this channel
 172     if ($t >= $chan->t + $main::user_interval) {
 173       $chan->prompt() if $chan->{state} =~ /^prompt/o;
 174           $chan->t($t);
 175         }
 176   }
 177 }
 178
 179 #
 180 # finish up a user context
 181 #
 182 sub finish
 183 {
 184   my $self = shift;
 185   my $call = $self->call;
 186
 187   if ($call eq $main::myalias) {   # unset the channel if it is us really
 188     my $node = DXNode->get($main::mycall);
 189         $node->{dxchan} = 0;
 190   }
 191   my $ref = DXNodeuser->get($call);
 192
 193   # issue a pc17 to everybody interested
 194   my $nchan = DXChannel->get($main::mycall);
 195   my $pc17 = $nchan->pc17($self);
 196   DXProt::broadcast_ak1a($pc17);
 197
 198   $ref->del() if $ref;
 199 }
 200
 201 #
 202 # short cut to output a prompt
 203 #
 204
 205 sub prompt
 206 {
 207   my $self = shift;
 208   my $call = $self->{call};
 209   $self->send($self->msg('pr', $call));
 210   #DXChannel::msg($self, 'pr', $call);
 211 }
 212
 213 # broadcast a message to all users [except those mentioned after buffer]
 214 sub broadcast
 215 {
 216   my $pkg = shift;                # ignored
 217   my $s = shift;                  # the line to be rebroadcast
 218   my @except = @_;                # to all channels EXCEPT these (dxchannel refs)
 219   my @list = DXChannel->get_all();   # just in case we are called from some funny object
 220   my ($chan, $except);
 221
 222 L: foreach $chan (@list) {
 223      next if !$chan->sort eq 'U';  # only interested in user channels
 224          foreach $except (@except) {
 225            next L if $except == $chan;  # ignore channels in the 'except' list
 226          }
 227          chan->send($s);              # send it
 228   }
 229 }
 230
 231 # gimme all the users
 232 sub get_all
 233 {
 234   my @list = DXChannel->get_all();
 235   my $ref;
 236   my @out;
 237   foreach $ref (@list) {
 238     push @out, $ref if $ref->sort eq 'U';
 239   }
 240   return @out;
 241 }
 242
 243 #
 244 # search for the command in the cache of short->long form commands
 245 #
 246
 247 sub search
 248 {
 249   my ($path, $short_cmd, $suffix) = @_;
 250   my ($apath, $acmd);
 251
 252   # commands are lower case
 253   $short_cmd = lc $short_cmd;
 254   dbg('command', "command: $path $short_cmd\n");
 255
 256   # return immediately if we have it
 257   my ($apath, $acmd) = split ',', $cmd_cache{$short_cmd};
 258   if ($apath && $acmd) {
 259     dbg('command', "cached $short_cmd = ($apath, $acmd)\n");
 260     return ($apath, $acmd);
 261   }
 262
 263   # if not guess
 264   my @parts = split '/', $short_cmd;
 265   my $dirfn;
 266   my $curdir = $path;
 267   my $p;
 268   my $i;
 269   my @lparts;
 270
 271   for ($i = 0; $i < @parts; $i++) {
 272     my  $p = $parts[$i];
 273         opendir(D, $curdir) or confess "can't open $curdir $!";
 274         my @ls = readdir D;
 275         closedir D;
 276         my $l;
 277         foreach $l (sort @ls) {
 278           next if $l =~ /^\./;
 279       if ($i < $#parts) {            # we are dealing with directories
 280         if ((-d "$curdir/$l") && $p eq substr($l, 0, length $p)) {
 281                   dbg('command', "got dir: $curdir/$l\n");
 282                   $dirfn .= "$l/";
 283                   $curdir .= "/$l";
 284                   last;
 285                 }
 286       } else {                # we are dealing with commands
 287             @lparts = split /\./, $l;
 288                 next if $lparts[$#lparts] ne $suffix;       # only look for .$suffix files
 289                 if ($p eq substr($l, 0, length $p)) {
 290                   pop @lparts;        #  remove the suffix
 291                   $l = join '.', @lparts;
 292 #                 chop $dirfn;               # remove trailing /
 293                   $cmd_cache{"$short_cmd"} = join(',', ($path, "$dirfn$l"));   # cache it
 294           dbg('command', "got path: $path cmd: $dirfn$l\n");
 295                   return ($path, "$dirfn$l");
 296                 }
 297           }
 298         }
 299   }
 300   return ();
 301 }
 302
 303 # clear the command name cache
 304 sub clear_cmd_cache
 305 {
 306   %cmd_cache = ();
 307 }
 308
 309 #
 310 # the persistant execution of things from the command directories
 311 #
 312 #
 313 # This allows perl programs to call functions dynamically
 314 #
 315 # This has been nicked directly from the perlembed pages
 316 #
 317
 318 #require Devel::Symdump;
 319
 320 sub valid_package_name {
 321   my($string) = @_;
 322   $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg;
 323
 324   #second pass only for words starting with a digit
 325   $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg;
 326
 327   #Dress it up as a real package name
 328   $string =~ s/\//_/og;
 329   return "Emb_" . $string;
 330 }
 331
 332 #borrowed from Safe.pm
 333 sub delete_package {
 334   my $pkg = shift;
 335   my ($stem, $leaf);
 336
 337   no strict 'refs';
 338   $pkg = "DXCommandmode::$pkg\::";    # expand to full symbol table name
 339   ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
 340
 341   if ($stem && $leaf) {
 342     my $stem_symtab = *{$stem}{HASH};
 343     delete $stem_symtab->{$leaf};
 344   }
 345 }
 346
 347 # find a cmd reference
 348 # this is really for use in user written stubs
 349 #
 350 # use the result as a symbolic reference:-
 351 #
 352 # no strict 'refs';
 353 # @out = &$r($self, $line);
 354 #
 355 sub find_cmd_ref
 356 {
 357   my $cmd = shift;
 358   my $r;
 359
 360   if ($cmd) {
 361
 362     # first expand out the entry to a command
 363     my ($path, $fcmd) = search($main::localcmd, $cmd, "pl");
 364     ($path, $fcmd) = search($main::cmd, $cmd, "pl") if !$path || !$fcmd;
 365
 366     # make sure it is loaded
 367     $r = find_cmd_name($path, $fcmd);
 368   }
 369   return $r;
 370 }
 371
 372 #
 373 # this bit of magic finds a command in the offered directory
 374 sub find_cmd_name {
 375   my $path = shift;
 376   my $cmdname = shift;
 377   my $package = valid_package_name($cmdname);
 378   my $filename = "$path/$cmdname.pl";
 379   my $mtime = -M $filename;
 380
 381   # return if we can't find it
 382   $errstr = undef;
 383   if (undef $mtime) {
 384     $errstr = DXM::msg('e1');
 385         return undef;
 386   }
 387
 388   if(defined $Cache{$package}{mtime} && $Cache{$package}{mtime } <= $mtime) {
 389     #we have compiled this subroutine already,
 390         #it has not been updated on disk, nothing left to do
 391         #print STDERR "already compiled $package->handler\n";
 392         ;
 393   } else {
 394         my $fh = new FileHandle;
 395         if (!open $fh, $filename) {
 396           $errstr = "Syserr: can't open '$filename' $!";
 397           return undef;
 398         };
 399         local $/ = undef;
 400         my $sub = <$fh>;
 401         close $fh;
 402
 403     #wrap the code into a subroutine inside our unique package
 404         my $eval = qq{
 405         sub $package
 406         {
 407           $sub
 408         } };
 409
 410         if (isdbg('eval')) {
 411           my @list = split /\n/, $eval;
 412           my $line;
 413           for (@list) {
 414             dbg('eval', $_, "\n");
 415           }
 416         }
 417
 418         {
 419           #hide our variables within this block
 420           my($filename,$mtime,$package,$sub);
 421           eval $eval;
 422         }
 423
 424         if ($@) {
 425           print "\$\@ = $@";
 426           $errstr = $@;
 427           delete_package($package);
 428         } else {
 429       #cache it unless we're cleaning out each time
 430           $Cache{$package}{mtime} = $mtime;
 431         }
 432   }
 433
 434   #print Devel::Symdump->rnew($package)->as_string, $/;
 435   $package = "DXCommandmode::$package" if $package;
 436   $package = undef if $errstr;
 437   return $package;
 438 }
 439
 440 1;
 441 __END__