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   if ($ans[0]) {
 141     shift @ans;
 142         $self->send(@ans) if @ans > 0;
 143   } else {
 144     shift @ans;
 145         if (@ans > 0) {
 146           $self->send($self->msg('e2'), @ans);
 147         } else {
 148       $self->send($self->msg('e1'));
 149         }
 150   }
 151
 152   # send a prompt only if we are in a prompt state
 153   $self->prompt() if $self->{state} =~ /^prompt/o;
 154 }
 155
 156 #
 157 # This is called from inside the main cluster processing loop and is used
 158 # for despatching commands that are doing some long processing job
 159 #
 160 sub process
 161 {
 162   my $t = time;
 163   my @chan = DXChannel->get_all();
 164   my $chan;
 165
 166   foreach $chan (@chan) {
 167     next if $chan->sort ne 'U';
 168
 169     # send a prompt if no activity out on this channel
 170     if ($t >= $chan->t + $main::user_interval) {
 171       $chan->prompt() if $chan->{state} =~ /^prompt/o;
 172           $chan->t($t);
 173         }
 174   }
 175 }
 176
 177 #
 178 # finish up a user context
 179 #
 180 sub finish
 181 {
 182   my $self = shift;
 183   my $call = $self->call;
 184
 185   if ($call eq $main::myalias) {   # unset the channel if it is us really
 186     my $node = DXNode->get($main::mycall);
 187         $node->{dxchan} = 0;
 188   }
 189   my $ref = DXNodeuser->get($call);
 190
 191   # issue a pc17 to everybody interested
 192   my $nchan = DXChannel->get($main::mycall);
 193   my $pc17 = $nchan->pc17($self);
 194   DXProt::broadcast_ak1a($pc17);
 195
 196   $ref->del() if $ref;
 197 }
 198
 199 #
 200 # short cut to output a prompt
 201 #
 202
 203 sub prompt
 204 {
 205   my $self = shift;
 206   my $call = $self->{call};
 207   $self->send($self->msg('pr', $call));
 208   #DXChannel::msg($self, 'pr', $call);
 209 }
 210
 211 # broadcast a message to all users [except those mentioned after buffer]
 212 sub broadcast
 213 {
 214   my $pkg = shift;                # ignored
 215   my $s = shift;                  # the line to be rebroadcast
 216   my @except = @_;                # to all channels EXCEPT these (dxchannel refs)
 217   my @list = DXChannel->get_all();   # just in case we are called from some funny object
 218   my ($chan, $except);
 219
 220 L: foreach $chan (@list) {
 221      next if !$chan->sort eq 'U';  # only interested in user channels
 222          foreach $except (@except) {
 223            next L if $except == $chan;  # ignore channels in the 'except' list
 224          }
 225          chan->send($s);              # send it
 226   }
 227 }
 228
 229 # gimme all the users
 230 sub get_all
 231 {
 232   my @list = DXChannel->get_all();
 233   my $ref;
 234   my @out;
 235   foreach $ref (@list) {
 236     push @out, $ref if $ref->sort eq 'U';
 237   }
 238   return @out;
 239 }
 240
 241 #
 242 # search for the command in the cache of short->long form commands
 243 #
 244
 245 sub search
 246 {
 247   my ($path, $short_cmd, $suffix) = @_;
 248   my ($apath, $acmd);
 249
 250   # commands are lower case
 251   $short_cmd = lc $short_cmd;
 252   dbg('command', "command: $path $short_cmd\n");
 253
 254   # return immediately if we have it
 255   my ($apath, $acmd) = split ',', $cmd_cache{$short_cmd};
 256   if ($apath && $acmd) {
 257     dbg('command', "cached $short_cmd = ($apath, $acmd)\n");
 258     return ($apath, $acmd);
 259   }
 260
 261   # if not guess
 262   my @parts = split '/', $short_cmd;
 263   my $dirfn;
 264   my $curdir = $path;
 265   my $p;
 266   my $i;
 267   my @lparts;
 268
 269   for ($i = 0; $i < @parts; $i++) {
 270     my  $p = $parts[$i];
 271         opendir(D, $curdir) or confess "can't open $curdir $!";
 272         my @ls = readdir D;
 273         closedir D;
 274         my $l;
 275         foreach $l (sort @ls) {
 276           next if $l =~ /^\./;
 277       if ($i < $#parts) {            # we are dealing with directories
 278         if ((-d "$curdir/$l") && $p eq substr($l, 0, length $p)) {
 279                   dbg('command', "got dir: $curdir/$l\n");
 280                   $dirfn .= "$l/";
 281                   $curdir .= "/$l";
 282                   last;
 283                 }
 284       } else {                # we are dealing with commands
 285             @lparts = split /\./, $l;
 286                 next if $lparts[$#lparts] ne $suffix;       # only look for .$suffix files
 287                 if ($p eq substr($l, 0, length $p)) {
 288                   pop @lparts;        #  remove the suffix
 289                   $l = join '.', @lparts;
 290 #                 chop $dirfn;               # remove trailing /
 291                   $cmd_cache{"$short_cmd"} = join(',', ($path, "$dirfn$l"));   # cache it
 292           dbg('command', "got path: $path cmd: $dirfn$l\n");
 293                   return ($path, "$dirfn$l");
 294                 }
 295           }
 296         }
 297   }
 298   return ();
 299 }
 300
 301 # clear the command name cache
 302 sub clear_cmd_cache
 303 {
 304   %cmd_cache = ();
 305 }
 306
 307 #
 308 # the persistant execution of things from the command directories
 309 #
 310 #
 311 # This allows perl programs to call functions dynamically
 312 #
 313 # This has been nicked directly from the perlembed pages
 314 #
 315
 316 #require Devel::Symdump;
 317
 318 sub valid_package_name {
 319   my($string) = @_;
 320   $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg;
 321
 322   #second pass only for words starting with a digit
 323   $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg;
 324
 325   #Dress it up as a real package name
 326   $string =~ s/\//_/og;
 327   return "Emb_" . $string;
 328 }
 329
 330 #borrowed from Safe.pm
 331 sub delete_package {
 332   my $pkg = shift;
 333   my ($stem, $leaf);
 334
 335   no strict 'refs';
 336   $pkg = "DXCommandmode::$pkg\::";    # expand to full symbol table name
 337   ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
 338
 339   if ($stem && $leaf) {
 340     my $stem_symtab = *{$stem}{HASH};
 341     delete $stem_symtab->{$leaf};
 342   }
 343 }
 344
 345 # find a cmd reference
 346 # this is really for use in user written stubs
 347 #
 348 # use the result as a symbolic reference:-
 349 #
 350 # no strict 'refs';
 351 # @out = &$r($self, $line);
 352 #
 353 sub find_cmd_ref
 354 {
 355   my $cmd = shift;
 356   my $r;
 357
 358   if ($cmd) {
 359
 360     # first expand out the entry to a command
 361     my ($path, $fcmd) = search($main::localcmd, $cmd, "pl");
 362     ($path, $fcmd) = search($main::cmd, $cmd, "pl") if !$path || !$fcmd;
 363
 364     # make sure it is loaded
 365     $r = find_cmd_name($path, $fcmd);
 366   }
 367   return $r;
 368 }
 369
 370 #
 371 # this bit of magic finds a command in the offered directory
 372 sub find_cmd_name {
 373   my $path = shift;
 374   my $cmdname = shift;
 375   my $package = valid_package_name($cmdname);
 376   my $filename = "$path/$cmdname.pl";
 377   my $mtime = -M $filename;
 378
 379   # return if we can't find it
 380   $errstr = undef;
 381   if (undef $mtime) {
 382     $errstr = DXM::msg('e1');
 383         return undef;
 384   }
 385
 386   if(defined $Cache{$package}{mtime} && $Cache{$package}{mtime } <= $mtime) {
 387     #we have compiled this subroutine already,
 388         #it has not been updated on disk, nothing left to do
 389         #print STDERR "already compiled $package->handler\n";
 390         ;
 391   } else {
 392         my $fh = new FileHandle;
 393         if (!open $fh, $filename) {
 394           $errstr = "Syserr: can't open '$filename' $!";
 395           return undef;
 396         };
 397         local $/ = undef;
 398         my $sub = <$fh>;
 399         close $fh;
 400
 401     #wrap the code into a subroutine inside our unique package
 402         my $eval = qq{
 403         sub $package
 404         {
 405           $sub
 406         } };
 407
 408         if (isdbg('eval')) {
 409           my @list = split /\n/, $eval;
 410           my $line;
 411           for (@list) {
 412             dbg('eval', $_, "\n");
 413           }
 414         }
 415
 416         {
 417           #hide our variables within this block
 418           my($filename,$mtime,$package,$sub);
 419           eval $eval;
 420         }
 421
 422         if ($@) {
 423           print "\$\@ = $@";
 424           $errstr = $@;
 425           delete_package($package);
 426         } else {
 427       #cache it unless we're cleaning out each time
 428           $Cache{$package}{mtime} = $mtime;
 429         }
 430   }
 431
 432   #print Devel::Symdump->rnew($package)->as_string, $/;
 433   $package = "DXCommandmode::$package" if $package;
 434   $package = undef if $errstr;
 435   return $package;
 436 }
 437
 438 1;
 439 __END__