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