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} = 10;                # 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 @parts = split |[/\b]+|, $cmd;
  60
  61   # first expand out the entry to a command, note that I will accept
  62   # anything in any case with any (reasonable) seperator
  63   $self->prompt();
  64 }
  65
  66 #
  67 # This is called from inside the main cluster processing loop and is used
  68 # for despatching commands that are doing some long processing job
  69 #
  70 sub user_process
  71 {
  72
  73 }
  74
  75 #
  76 # finish up a user context
  77 #
  78 sub user_finish
  79 {
  80
  81 }
  82
  83 #
  84 # short cut to output a prompt
  85 #
  86
  87 sub prompt
  88 {
  89   my $self = shift;
  90   my $call = $self->{call};
  91   $self->msg('pr', $call);
  92 }
  93
  94 #
  95 # scan the command directories to see if things have changed
  96 #
  97 # If they have remake the command list
  98 #
  99 # There are two command directories a) the standard one and b) the local one
 100 # The local one overides the standard one
 101 #
 102
 103 sub scan_cmd_dirs
 104 {
 105   my $self = shift;
 106
 107
 108 }
 109
 110 #
 111 # the persistant execution of things from the command directories
 112 #
 113 #
 114 # This allows perl programs to call functions dynamically
 115 #
 116 # This has been nicked directly from the perlembed pages
 117 #
 118
 119 #require Devel::Symdump;
 120 use strict;
 121 use vars '%Cache';
 122
 123 sub valid_package_name {
 124   my($string) = @_;
 125   $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg;
 126
 127   #second pass only for words starting with a digit
 128   $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg;
 129
 130   #Dress it up as a real package name
 131   $string =~ s|/|::|g;
 132   return "DXEmbed" . $string;
 133 }
 134
 135 #borrowed from Safe.pm
 136 sub delete_package {
 137   my $pkg = shift;
 138   my ($stem, $leaf);
 139
 140   no strict 'refs';
 141   $pkg = "main::$pkg\::";    # expand to full symbol table name
 142   ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
 143
 144   my $stem_symtab = *{$stem}{HASH};
 145
 146   delete $stem_symtab->{$leaf};
 147 }
 148
 149 sub eval_file {
 150   my($self, $path, $cmdname) = @_;
 151   my $package = valid_package_name($cmdname);
 152   my $filename = "$path/$cmdname";
 153   my $mtime = -m $filename;
 154   my @r;
 155
 156   if(defined $Cache{$package}{mtime} && $Cache{$package}{mtime } <= $mtime) {
 157     #we have compiled this subroutine already,
 158         #it has not been updated on disk, nothing left to do
 159         #print STDERR "already compiled $package->handler\n";
 160         ;
 161   } else {
 162         local *FH;
 163         open FH, $filename or die "open '$filename' $!";
 164         local($/) = undef;
 165         my $sub = <FH>;
 166         close FH;
 167
 168     #wrap the code into a subroutine inside our unique package
 169         my $eval = qq{package $package; sub handler { $sub; }};
 170         {
 171           #hide our variables within this block
 172           my($filename,$mtime,$package,$sub);
 173           eval $eval;
 174         }
 175         if ($@) {
 176           $self->send("Eval err $@ on $package");
 177           delete_package($package);
 178           return undef;
 179         }
 180
 181         #cache it unless we're cleaning out each time
 182         $Cache{$package}{mtime} = $mtime unless $delete;
 183   }
 184
 185   @r = eval {$package->handler;};
 186   if ($@) {
 187     $self->send("Eval err $@ on cached $package");
 188     delete_package($package);
 189         return undef;
 190   }
 191
 192   #take a look if you want
 193   #print Devel::Symdump->rnew($package)->as_string, $/;
 194   return @r;
 195 }
 196
 197 1;
 198 __END__