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