3 # This module impliments the user facing command mode for a dx cluster
5 # Copyright (c) 1998 Dirk Koopman G1TLH
10 package DXCommandmode;
20 use vars qw( %Cache $last_dir_mtime @cmd);
22 $last_dir_mtime = 0; # the last time one of the cmd dirs was modified
23 @cmd = undef; # a list of commands+path pairs (in alphabetical order)
25 # this is how a a connection starts, you get a hello message and the motd with
26 # possibly some other messages asking you to set various things up if you are
27 # new (or nearly new and slacking) user.
32 my $user = $self->{user};
33 my $call = $self->{call};
34 my $name = $self->{name};
35 $name = $call if !defined $name;
36 $self->msg('l2',$name);
37 $self->send_file($main::motd) if (-e $main::motd);
38 $self->msg('pr', $call);
39 $self->state('prompt'); # a bit of room for further expansion, passwords etc
40 $self->{priv} = 0; # set the connection priv to 0 - can be upgraded later
44 # This is the normal command prompt driver
49 my $user = $self->{user};
50 my $call = $self->{call};
54 $cmdline =~ s|//|/|og;
56 # split the command line up into parts, the first part is the command
57 my ($cmd, $args) = $cmdline =~ /^([\w\/]+)\s*(.*)/o;
61 # first expand out the entry to a command
64 my @ans = $self->eval_file($main::localcmd, $cmd, $args);
65 @ans = $self->eval_file($main::cmd, $cmd, $args) if !$ans[0];
68 $self->send(@ans) if @ans > 0;
72 $self->msg('e2', @ans);
81 # send a prompt only if we are in a prompt state
82 $self->prompt() if $self->{state} =~ /^prompt/o;
86 # This is called from inside the main cluster processing loop and is used
87 # for despatching commands that are doing some long processing job
95 # finish up a user context
103 # short cut to output a prompt
109 my $call = $self->{call};
110 DXChannel::msg($self, 'pr', $call);
114 # search for the command in the cache of short->long form commands
119 my $short_cmd = shift;
120 return $short_cmd; # just return it for now
124 # the persistant execution of things from the command directories
127 # This allows perl programs to call functions dynamically
129 # This has been nicked directly from the perlembed pages
132 #require Devel::Symdump;
134 sub valid_package_name {
136 $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg;
138 #second pass only for words starting with a digit
139 $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg;
141 #Dress it up as a real package name
143 return "Emb_" . $string;
146 #borrowed from Safe.pm
152 $pkg = "DXChannel::$pkg\::"; # expand to full symbol table name
153 ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
155 my $stem_symtab = *{$stem}{HASH};
157 delete $stem_symtab->{$leaf};
164 my $package = valid_package_name($cmdname);
165 my $filename = "$path/$cmdname";
166 my $mtime = -M $filename;
168 # return if we can't find it
169 return (0, DXM::msg('e1')) if !defined $mtime;
171 if(defined $Cache{$package}{mtime} && $Cache{$package}{mtime } <= $mtime) {
172 #we have compiled this subroutine already,
173 #it has not been updated on disk, nothing left to do
174 #print STDERR "already compiled $package->handler\n";
178 if (!open FH, $filename) {
179 return (0, "Syserr: can't open '$filename' $!");
185 #wrap the code into a subroutine inside our unique package
186 my $eval = qq{package DXChannel; sub $package { $sub; }};
187 print "eval $eval\n";
189 #hide our variables within this block
190 my($filename,$mtime,$package,$sub);
194 delete_package($package);
195 return (0, "Syserr: Eval err $@ on $package");
198 #cache it unless we're cleaning out each time
199 $Cache{$package}{mtime} = $mtime;
203 my $c = qq{ \@r = \$self->$package(\@_); };
207 delete_package($package);
208 return (0, "Syserr: Eval err $@ on cached $package");
211 #take a look if you want
212 #print Devel::Symdump->rnew($package)->as_string, $/;