3 # This module impliments the user facing command mode for a dx cluster
5 # Copyright (c) 1998 Dirk Koopman G1TLH
10 package DXCommandmode;
21 use vars qw( %Cache $last_dir_mtime @cmd);
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)
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.
32 my ($self, $line) = @_;
33 my $user = $self->{user};
34 my $call = $self->{call};
35 my $name = $user->{name};
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 $self->sort('U'); # set the channel type
49 # This is the normal command prompt driver
54 my $user = $self->{user};
55 my $call = $self->{call};
59 $cmdline =~ s|//|/|og;
61 # split the command line up into parts, the first part is the command
62 my ($cmd, $args) = $cmdline =~ /^([\w\/]+)\s*(.*)/o;
66 # first expand out the entry to a command
69 my @ans = $self->eval_file($main::localcmd, $cmd, $args);
70 @ans = $self->eval_file($main::cmd, $cmd, $args) if !$ans[0];
73 $self->send(@ans) if @ans > 0;
77 $self->msg('e2', @ans);
86 # send a prompt only if we are in a prompt state
87 $self->prompt() if $self->{state} =~ /^prompt/o;
91 # This is called from inside the main cluster processing loop and is used
92 # for despatching commands that are doing some long processing job
97 my @chan = DXChannel->get_all();
100 foreach $chan (@chan) {
101 next if $chan->sort ne 'U';
103 # send a prompt if no activity out on this channel
104 if ($t >= $chan->t + $main::user_interval) {
105 $chan->prompt() if $chan->{state} =~ /^prompt/o;
112 # finish up a user context
120 # short cut to output a prompt
126 my $call = $self->{call};
127 DXChannel::msg($self, 'pr', $call);
131 # search for the command in the cache of short->long form commands
136 my $short_cmd = shift;
137 return $short_cmd; # just return it for now
141 # the persistant execution of things from the command directories
144 # This allows perl programs to call functions dynamically
146 # This has been nicked directly from the perlembed pages
149 #require Devel::Symdump;
151 sub valid_package_name {
153 $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg;
155 #second pass only for words starting with a digit
156 $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg;
158 #Dress it up as a real package name
160 return "Emb_" . $string;
163 #borrowed from Safe.pm
169 $pkg = "DXChannel::$pkg\::"; # expand to full symbol table name
170 ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
172 my $stem_symtab = *{$stem}{HASH};
174 delete $stem_symtab->{$leaf};
181 my $package = valid_package_name($cmdname);
182 my $filename = "$path/$cmdname.pl";
183 my $mtime = -M $filename;
185 # return if we can't find it
186 return (0, DXM::msg('e1')) if !defined $mtime;
188 if(defined $Cache{$package}{mtime} && $Cache{$package}{mtime } <= $mtime) {
189 #we have compiled this subroutine already,
190 #it has not been updated on disk, nothing left to do
191 #print STDERR "already compiled $package->handler\n";
195 if (!open FH, $filename) {
196 return (0, "Syserr: can't open '$filename' $!");
202 #wrap the code into a subroutine inside our unique package
203 my $eval = qq{package DXChannel; sub $package { $sub; }};
205 my @list = split /\n/, $eval;
208 dbg('eval', $_, "\n");
211 #print "eval $eval\n";
213 #hide our variables within this block
214 my($filename,$mtime,$package,$sub);
218 delete_package($package);
219 return (0, "Syserr: Eval err $@ on $package");
222 #cache it unless we're cleaning out each time
223 $Cache{$package}{mtime} = $mtime;
227 my $c = qq{ \@r = \$self->$package(\@_); };
228 dbg('eval', "cluster cmd = $c\n");
231 delete_package($package);
232 return (0, "Syserr: Eval err $@ on cached $package");
235 #take a look if you want
236 #print Devel::Symdump->rnew($package)->as_string, $/;