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   # add yourself to the database
  64   my $node = DXNode->get($main::mycall) or die "$main::mycall not allocated in DXNode database";
  65   my $cuser = DXNodeuser->new($self, $node, $call, 0, 1);
  66   $node->dxchan($self) if $call eq $main::myalias;       # send all output for mycall to myalias
  67
  68   # issue a pc16 to everybody interested
  69   my $nchan = DXChannel->get($main::mycall);
  70   my $pc16 = $nchan->pc16($cuser);
  71   DXProt::broadcast_ak1a($pc16);
  72 }
  73
  74 #
  75 # This is the normal command prompt driver
  76 #
  77 sub normal
  78 {
  79   my $self = shift;
  80   my $user = $self->{user};
  81   my $call = $self->{call};
  82   my $cmdline = shift;
  83
  84   # strip out //
  85   $cmdline =~ s|//|/|og;
  86
  87   # split the command line up into parts, the first part is the command
  88   my ($cmd, $args) = $cmdline =~ /^([\w\/]+)\s*(.*)/o;
  89
  90   if ($cmd) {
  91
  92         my ($path, $fcmd);
  93
  94     # first expand out the entry to a command
  95     ($path, $fcmd) = search($main::localcmd, $cmd, "pl");
  96     ($path, $fcmd) = search($main::cmd, $cmd, "pl") if !$path || !$fcmd;
  97
  98     my @ans = $self->eval_file($path, $fcmd, $args) if $path && $fcmd;
  99 #       @ans = $self->eval_file($main::cmd, $cmd, $args) if !$ans[0];
 100         if ($ans[0]) {
 101       shift @ans;
 102           $self->send(@ans) if @ans > 0;
 103         } else {
 104       shift @ans;
 105           if (@ans > 0) {
 106             $self->msg('e2', @ans);
 107           } else {
 108         $self->msg('e1');
 109           }
 110         }
 111   } else {
 112     $self->msg('e1');
 113   }
 114
 115   # send a prompt only if we are in a prompt state
 116   $self->prompt() if $self->{state} =~ /^prompt/o;
 117 }
 118
 119 #
 120 # This is called from inside the main cluster processing loop and is used
 121 # for despatching commands that are doing some long processing job
 122 #
 123 sub process
 124 {
 125   my $t = time;
 126   my @chan = DXChannel->get_all();
 127   my $chan;
 128
 129   foreach $chan (@chan) {
 130     next if $chan->sort ne 'U';
 131
 132     # send a prompt if no activity out on this channel
 133     if ($t >= $chan->t + $main::user_interval) {
 134       $chan->prompt() if $chan->{state} =~ /^prompt/o;
 135           $chan->t($t);
 136         }
 137   }
 138 }
 139
 140 #
 141 # finish up a user context
 142 #
 143 sub finish
 144 {
 145   my $self = shift;
 146   my $call = $self->call;
 147
 148   if ($call eq $main::myalias) {   # unset the channel if it is us really
 149     my $node = DXNode->get($main::mycall);
 150         $node->{dxchan} = 0;
 151   }
 152   my $ref = DXNodeuser->get($call);
 153
 154   # issue a pc17 to everybody interested
 155   my $nchan = DXChannel->get($main::mycall);
 156   my $pc17 = $nchan->pc17($ref);
 157   DXProt::broadcast_ak1a($pc17);
 158
 159   $ref->del() if $ref;
 160 }
 161
 162 #
 163 # short cut to output a prompt
 164 #
 165
 166 sub prompt
 167 {
 168   my $self = shift;
 169   my $call = $self->{call};
 170   DXChannel::msg($self, 'pr', $call);
 171 }
 172
 173 # broadcast a message to all users [except those mentioned after buffer]
 174 sub broadcast
 175 {
 176   my $pkg = shift;                # ignored
 177   my $s = shift;                  # the line to be rebroadcast
 178   my @except = @_;                # to all channels EXCEPT these (dxchannel refs)
 179   my @list = DXChannel->get_all();   # just in case we are called from some funny object
 180   my ($chan, $except);
 181
 182 L: foreach $chan (@list) {
 183      next if !$chan->sort eq 'U';  # only interested in user channels
 184          foreach $except (@except) {
 185            next L if $except == $chan;  # ignore channels in the 'except' list
 186          }
 187          chan->send($s);              # send it
 188   }
 189 }
 190
 191 # gimme all the users
 192 sub get_all
 193 {
 194   my @list = DXChannel->get_all();
 195   my $ref;
 196   my @out;
 197   foreach $ref (@list) {
 198     push @out, $ref if $ref->sort eq 'U';
 199   }
 200   return @out;
 201 }
 202
 203 #
 204 # search for the command in the cache of short->long form commands
 205 #
 206
 207 sub search
 208 {
 209   my ($path, $short_cmd, $suffix) = @_;
 210   my ($apath, $acmd);
 211
 212   # commands are lower case
 213   $short_cmd = lc $short_cmd;
 214   dbg('command', "command: $path $short_cmd\n");
 215
 216   # return immediately if we have it
 217   my ($apath, $acmd) = split ',', $cmd_cache{$short_cmd};
 218   if ($apath && $acmd) {
 219     dbg('command', "cached $short_cmd = ($apath, $acmd)\n");
 220     return ($apath, $acmd) if $apath;
 221   }
 222
 223   # if not guess
 224   my @parts = split '/', $short_cmd;
 225   my $dirfn;
 226   my $curdir = $path;
 227   my $p;
 228   my $i;
 229
 230   for ($i = 0; $i < @parts; $i++) {
 231     my  $p = $parts[$i];
 232         opendir(D, $curdir) or confess "can't open $curdir $!";
 233         my @ls = readdir D;
 234         closedir D;
 235         my $l;
 236         foreach $l (sort @ls) {
 237           next if $l =~ /^\./;
 238       if ($i < $#parts) {            # we are dealing with directories
 239         if ((-d "$curdir/$l") && $p eq substr($l, 0, length $p)) {
 240                   dbg('command', "got dir: $curdir/$l\n");
 241                   $dirfn .= "$l/";
 242                   $curdir .= "/$l";
 243                   last;
 244                 }
 245       } else {                       # we are dealing with commands
 246                 next if !$l =~ /\.$suffix$/;       # only look for .$suffix files
 247                 if ($p eq substr($l, 0, length $p)) {
 248                   $l =~ s/\.$suffix$//;      # remove the suffix
 249                   chop $dirfn;               # remove trailing /
 250                   $cmd_cache{"$short_cmd"} = join(',', ($path, "$dirfn/$l"));   # cache it
 251           dbg('command', "got path: $path cmd: $dirfn/$l\n");
 252                   return ($path, "$dirfn/$l");
 253                 }
 254           }
 255         }
 256   }
 257   return ();
 258 }
 259
 260 # clear the command name cache
 261 sub clear_cmd_cache
 262 {
 263   %cmd_cache = ();
 264 }
 265
 266 #
 267 # the persistant execution of things from the command directories
 268 #
 269 #
 270 # This allows perl programs to call functions dynamically
 271 #
 272 # This has been nicked directly from the perlembed pages
 273 #
 274
 275 #require Devel::Symdump;
 276
 277 sub valid_package_name {
 278   my($string) = @_;
 279   $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg;
 280
 281   #second pass only for words starting with a digit
 282   $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg;
 283
 284   #Dress it up as a real package name
 285   $string =~ s|/|_|g;
 286   return "Emb_" . $string;
 287 }
 288
 289 #borrowed from Safe.pm
 290 sub delete_package {
 291   my $pkg = shift;
 292   my ($stem, $leaf);
 293
 294   no strict 'refs';
 295   $pkg = "DXChannel::$pkg\::";    # expand to full symbol table name
 296   ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
 297
 298   my $stem_symtab = *{$stem}{HASH};
 299
 300   delete $stem_symtab->{$leaf};
 301 }
 302
 303 sub eval_file {
 304   my $self = shift;
 305   my $path = shift;
 306   my $cmdname = shift;
 307   my $package = valid_package_name($cmdname);
 308   my $filename = "$path/$cmdname.pl";
 309   my $mtime = -M $filename;
 310
 311   # return if we can't find it
 312   return (0, DXM::msg('e1')) if !defined $mtime;
 313
 314   if(defined $Cache{$package}{mtime} && $Cache{$package}{mtime } <= $mtime) {
 315     #we have compiled this subroutine already,
 316         #it has not been updated on disk, nothing left to do
 317         #print STDERR "already compiled $package->handler\n";
 318         ;
 319   } else {
 320         local *FH;
 321         if (!open FH, $filename) {
 322           return (0, "Syserr: can't open '$filename' $!");
 323         };
 324         local($/) = undef;
 325         my $sub = <FH>;
 326         close FH;
 327
 328     #wrap the code into a subroutine inside our unique package
 329         my $eval = qq{package DXChannel; sub $package { $sub; }};
 330         if (isdbg('eval')) {
 331           my @list = split /\n/, $eval;
 332           my $line;
 333           foreach (@list) {
 334             dbg('eval', $_, "\n");
 335           }
 336         }
 337         #print "eval $eval\n";
 338         {
 339           #hide our variables within this block
 340           my($filename,$mtime,$package,$sub);
 341           eval $eval;
 342         }
 343         if ($@) {
 344           delete_package($package);
 345           return (0, "Syserr: Eval err $@ on $package");
 346         }
 347
 348         #cache it unless we're cleaning out each time
 349         $Cache{$package}{mtime} = $mtime;
 350   }
 351
 352   my @r;
 353   my $c = qq{ \@r = \$self->$package(\@_); };
 354   dbg('eval', "cluster cmd = $c\n");
 355   eval  $c; ;
 356   if ($@) {
 357     delete_package($package);
 358         return (0, "Syserr: Eval err $@ on cached $package");
 359   }
 360
 361   #take a look if you want
 362   #print Devel::Symdump->rnew($package)->as_string, $/;
 363   return @r;
 364 }
 365
 366 1;
 367 __END__