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