3 # This module impliments the user facing command mode for a dx cluster
5 # Copyright (c) 1998 Dirk Koopman G1TLH
10 package DXCommandmode;
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)
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.
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
42 # This is the normal command prompt driver
47 my $user = $self->{user};
48 my $call = $self->{call};
51 # read in the list of valid commands, note that the commands themselves are cached elsewhere
52 scan_cmd_dirs if (!defined %cmd);
54 # strip out any nasty characters like $@%&|. and double // etc.
55 $cmd =~ s/[\%\@\$\&\|\.\`\~]//og;
58 # split the command up into parts
59 my @parts = split |[/\b]+|, $cmd;
61 # first expand out the entry to a command, note that I will accept
62 # anything in any case with any (reasonable) seperator
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
76 # finish up a user context
84 # short cut to output a prompt
90 my $call = $self->{call};
91 $self->msg('pr', $call);
95 # scan the command directories to see if things have changed
97 # If they have remake the command list
99 # There are two command directories a) the standard one and b) the local one
100 # The local one overides the standard one
111 # the persistant execution of things from the command directories
114 # This allows perl programs to call functions dynamically
116 # This has been nicked directly from the perlembed pages
119 #require Devel::Symdump;
123 sub valid_package_name {
125 $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg;
127 #second pass only for words starting with a digit
128 $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg;
130 #Dress it up as a real package name
132 return "DXEmbed" . $string;
135 #borrowed from Safe.pm
141 $pkg = "main::$pkg\::"; # expand to full symbol table name
142 ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
144 my $stem_symtab = *{$stem}{HASH};
146 delete $stem_symtab->{$leaf};
150 my($self, $path, $cmdname) = @_;
151 my $package = valid_package_name($cmdname);
152 my $filename = "$path/$cmdname";
153 my $mtime = -m $filename;
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";
163 open FH, $filename or die "open '$filename' $!";
168 #wrap the code into a subroutine inside our unique package
169 my $eval = qq{package $package; sub handler { $sub; }};
171 #hide our variables within this block
172 my($filename,$mtime,$package,$sub);
176 $self->send("Eval err $@ on $package");
177 delete_package($package);
181 #cache it unless we're cleaning out each time
182 $Cache{$package}{mtime} = $mtime unless $delete;
185 @r = eval {$package->handler;};
187 $self->send("Eval err $@ on cached $package");
188 delete_package($package);
192 #take a look if you want
193 #print Devel::Symdump->rnew($package)->as_string, $/;