X-Git-Url: http://www.dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXCommandmode.pm;h=4ad01392dede6d82b09df9775084a0bf197247cd;hb=fa57f72c26032aae4c1a20358e829ba9afbf460c;hp=ae016cc6fd038250cf11d7158c80ce4486da7024;hpb=625ce0adf070a7e900fa03714a391652db0c065a;p=spider.git diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index ae016cc6..4ad01392 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -9,82 +9,255 @@ package DXCommandmode; +@ISA = qw(DXChannel); + use DXUtil; use DXChannel; use DXUser; -use DXM; use DXVars; +use DXDebug; +use DXM; +use DXLog; +use DXLogPrint; +use CmdAlias; +use FileHandle; +use Carp; -$last_dir_mtime = 0; # the last time one of the cmd dirs was modified -@cmd = undef; # a list of commands+path pairs (in alphabetical order) +use strict; +use vars qw(%Cache %cmd_cache $errstr %aliases); + +%Cache = (); # cache of dynamically loaded routine's mod times +%cmd_cache = (); # cache of short names +$errstr = (); # error string from eval +%aliases = (); # aliases for (parts of) commands + +# +# obtain a new connection this is derived from dxchannel +# + +sub new +{ + my $self = DXChannel::alloc(@_); + $self->{sort} = 'U'; # in absence of how to find out what sort of an object I am + return $self; +} # this is how a a connection starts, you get a hello message and the motd with # possibly some other messages asking you to set various things up if you are # new (or nearly new and slacking) user. -sub user_start +sub start { - my $self = shift; + my ($self, $line, $sort) = @_; my $user = $self->{user}; my $call = $self->{call}; - my $name = $self->{name}; - $name = $call if !defined $name; - $self->{normal} = \&user_normal; # rfu for now - $self->{finish} = \&user_finish; - $self->msg('l2',$name); + my $name = $user->{name}; + + $self->{name} = $name ? $name : $call; + $self->send($self->msg('l2',$self->{name})); $self->send_file($main::motd) if (-e $main::motd); - $self->msg('pr', $call); $self->state('prompt'); # a bit of room for further expansion, passwords etc - $self->{priv} = 0; # set the connection priv to 0 - can be upgraded later + $self->{priv} = $user->priv; + $self->{lang} = $user->lang; + $self->{pagelth} = 20; + $self->{priv} = 0 if $line =~ /^(ax|te)/; # set the connection priv to 0 - can be upgraded later + $self->{consort} = $line; # save the connection type + + # set some necessary flags on the user if they are connecting + $self->{wwv} = $self->{talk} = $self->{ann} = $self->{here} = $self->{dx} = 1; +# $self->prompt() if $self->{state} =~ /^prompt/o; + + # add yourself to the database + my $node = DXNode->get($main::mycall) or die "$main::mycall not allocated in DXNode database"; + my $cuser = DXNodeuser->new($self, $node, $call, 0, 1); + $node->dxchan($self) if $call eq $main::myalias; # send all output for mycall to myalias + + # issue a pc16 to everybody interested + my $nchan = DXChannel->get($main::mycall); + my @pc16 = DXProt::pc16($nchan, $cuser); + DXProt::broadcast_ak1a(@pc16); + Log('DXCommand', "$call connected"); + + # send prompts and things + my $info = DXCluster::cluster(); + $self->send("Cluster:$info"); + $self->send($self->msg('pr', $call)); } # # This is the normal command prompt driver # -sub user_normal + +sub normal { - my $self = shift; - my $user = $self->{user}; - my $call = $self->{call}; - my $cmd = shift; + my $self = shift; + my $cmdline = shift; + my @ans; + + # remove leading and trailing spaces + $cmdline =~ s/^\s*(.*)\s*$/$1/; + + if ($self->{state} eq 'page') { + my $i = $self->{pagelth}; + my $ref = $self->{pagedata}; + my $tot = @$ref; + + # abort if we get a line starting in with a + if ($cmdline =~ /^a/io) { + undef $ref; + $i = 0; + } + + # send a tranche of data + while ($i-- > 0 && @$ref) { + my $line = shift @$ref; + $line =~ s/\s+$//o; # why am having to do this? + $self->send($line); + } - # read in the list of valid commands, note that the commands themselves are cached elsewhere - scan_cmd_dirs if (!defined %cmd); - - # strip out any nasty characters like $@%&|. and double // etc. - $cmd =~ s/[%\@\$&\\.`~]//og; - $cmd =~ s|//|/|og; - - # split the command up into parts - my @part = split /[\/\b]+/, $cmd; - - # the bye command - temporary probably - if ($part[0] =~ /^b/io) { - $self->user_finish(); - $self->state('bye'); - return; - } + # reset state if none or else chuck out an intermediate prompt + if ($ref && @$ref) { + $tot -= $self->{pagelth}; + $self->send($self->msg('page', $tot)); + } else { + $self->state('prompt'); + } + } else { + @ans = run_cmd($self, $cmdline) if length $cmdline; + + if ($self->{pagelth} && @ans > $self->{pagelth}) { + my $i; + for ($i = $self->{pagelth}; $i-- > 0; ) { + my $line = shift @ans; + $line =~ s/\s+$//o; # why am having to do this? + $self->send($line); + } + $self->{pagedata} = \@ans; + $self->state('page'); + $self->send($self->msg('page', scalar @ans)); + } else { + for (@ans) { + s/\s+$//o; # why ????????? + $self->send($_); + } + } + } + + # send a prompt only if we are in a prompt state + $self->prompt() if $self->{state} =~ /^prompt/o; +} + +# +# this is the thing that runs the command, it is done like this for the +# benefit of remote command execution +# + +sub run_cmd +{ + my $self = shift; + my $user = $self->{user}; + my $call = $self->{call}; + my $cmdline = shift; + my @ans; + + if ($self->{func}) { + my $c = qq{ \@ans = $self->{func}(\$self, \$cmdline) }; + dbg('eval', "stored func cmd = $c\n"); + eval $c; + if ($@) { + return (1, "Syserr: Eval err $errstr on stored func $self->{func}"); + } + } else { + + # strip out // + $cmdline =~ s|//|/|og; + + # split the command line up into parts, the first part is the command + my ($cmd, $args) = $cmdline =~ /^([\w\/]+)\s*(.*)/o; + + if ($cmd) { + + my ($path, $fcmd); + + # alias it if possible + my $acmd = CmdAlias::get_cmd($cmd); + if ($acmd) { + ($cmd, $args) = "$acmd $args" =~ /^([\w\/]+)\s*(.*)/o; + } + + # first expand out the entry to a command + ($path, $fcmd) = search($main::localcmd, $cmd, "pl"); + ($path, $fcmd) = search($main::cmd, $cmd, "pl") if !$path || !$fcmd; + + my $package = find_cmd_name($path, $fcmd); + @ans = (0) if !$package ; + + if ($package) { + my $c = qq{ \@ans = $package(\$self, \$args) }; + dbg('eval', "cluster cmd = $c\n"); + eval $c; + if ($@) { + @ans = (0, "Syserr: Eval err cached $package\n$@"); + } + } + } + } - # first expand out the entry to a command, note that I will accept - # anything in any case with any (reasonable) seperator - $self->prompt(); + if ($ans[0]) { + shift @ans; + } else { + shift @ans; + if (@ans > 0) { + unshift @ans, $self->msg('e2'); + } else { + @ans = $self->msg('e1'); + } + } + return (@ans); } # # This is called from inside the main cluster processing loop and is used # for despatching commands that are doing some long processing job # -sub user_process +sub process { + my $t = time; + my @chan = DXChannel->get_all(); + my $chan; + + foreach $chan (@chan) { + next if $chan->sort ne 'U'; + # send a prompt if no activity out on this channel + if ($t >= $chan->t + $main::user_interval) { + $chan->prompt() if $chan->{state} =~ /^prompt/o; + $chan->t($t); + } + } } # # finish up a user context # -sub user_finish +sub finish { + my $self = shift; + my $call = $self->call; + + if ($call eq $main::myalias) { # unset the channel if it is us really + my $node = DXNode->get($main::mycall); + $node->{dxchan} = 0; + } + my $ref = DXNodeuser->get($call); + # issue a pc17 to everybody interested + my $nchan = DXChannel->get($main::mycall); + my $pc17 = $nchan->pc17($self); + DXProt::broadcast_ak1a($pc17); + + Log('DXCommand', "$call disconnected"); + $ref->del() if $ref; } # @@ -95,23 +268,104 @@ sub prompt { my $self = shift; my $call = $self->{call}; - $self->msg('pr', $call); + $self->send($self->msg('pr', $call)); + #DXChannel::msg($self, 'pr', $call); +} + +# broadcast a message to all users [except those mentioned after buffer] +sub broadcast +{ + my $pkg = shift; # ignored + my $s = shift; # the line to be rebroadcast + my @except = @_; # to all channels EXCEPT these (dxchannel refs) + my @list = DXChannel->get_all(); # just in case we are called from some funny object + my ($chan, $except); + +L: foreach $chan (@list) { + next if !$chan->sort eq 'U'; # only interested in user channels + foreach $except (@except) { + next L if $except == $chan; # ignore channels in the 'except' list + } + chan->send($s); # send it + } +} + +# gimme all the users +sub get_all +{ + my @list = DXChannel->get_all(); + my $ref; + my @out; + foreach $ref (@list) { + push @out, $ref if $ref->sort eq 'U'; + } + return @out; } # -# scan the command directories to see if things have changed -# -# If they have remake the command list -# -# There are two command directories a) the standard one and b) the local one -# The local one overides the standard one +# search for the command in the cache of short->long form commands # -sub scan_cmd_dirs +sub search { - my $self = shift; + my ($path, $short_cmd, $suffix) = @_; + my ($apath, $acmd); + # commands are lower case + $short_cmd = lc $short_cmd; + dbg('command', "command: $path $short_cmd\n"); + + # return immediately if we have it + my ($apath, $acmd) = split ',', $cmd_cache{$short_cmd}; + if ($apath && $acmd) { + dbg('command', "cached $short_cmd = ($apath, $acmd)\n"); + return ($apath, $acmd); + } + + # if not guess + my @parts = split '/', $short_cmd; + my $dirfn; + my $curdir = $path; + my $p; + my $i; + my @lparts; + + for ($i = 0; $i < @parts; $i++) { + my $p = $parts[$i]; + opendir(D, $curdir) or confess "can't open $curdir $!"; + my @ls = readdir D; + closedir D; + my $l; + foreach $l (sort @ls) { + next if $l =~ /^\./; + if ($i < $#parts) { # we are dealing with directories + if ((-d "$curdir/$l") && $p eq substr($l, 0, length $p)) { + dbg('command', "got dir: $curdir/$l\n"); + $dirfn .= "$l/"; + $curdir .= "/$l"; + last; + } + } else { # we are dealing with commands + @lparts = split /\./, $l; + next if $lparts[$#lparts] ne $suffix; # only look for .$suffix files + if ($p eq substr($l, 0, length $p)) { + pop @lparts; # remove the suffix + $l = join '.', @lparts; +# chop $dirfn; # remove trailing / + $cmd_cache{"$short_cmd"} = join(',', ($path, "$dirfn$l")); # cache it + dbg('command', "got path: $path cmd: $dirfn$l\n"); + return ($path, "$dirfn$l"); + } + } + } + } + return (); +} +# clear the command name cache +sub clear_cmd_cache +{ + %cmd_cache = (); } # @@ -124,8 +378,6 @@ sub scan_cmd_dirs # #require Devel::Symdump; -use strict; -use vars '%Cache'; sub valid_package_name { my($string) = @_; @@ -135,8 +387,8 @@ sub valid_package_name { $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg; #Dress it up as a real package name - $string =~ s|/|::|g; - return "DXEmbed" . $string; + $string =~ s/\//_/og; + return "Emb_" . $string; } #borrowed from Safe.pm @@ -145,20 +397,55 @@ sub delete_package { my ($stem, $leaf); no strict 'refs'; - $pkg = "main::$pkg\::"; # expand to full symbol table name + $pkg = "DXCommandmode::$pkg\::"; # expand to full symbol table name ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; - - my $stem_symtab = *{$stem}{HASH}; - - delete $stem_symtab->{$leaf}; + + if ($stem && $leaf) { + my $stem_symtab = *{$stem}{HASH}; + delete $stem_symtab->{$leaf}; + } +} + +# find a cmd reference +# this is really for use in user written stubs +# +# use the result as a symbolic reference:- +# +# no strict 'refs'; +# @out = &$r($self, $line); +# +sub find_cmd_ref +{ + my $cmd = shift; + my $r; + + if ($cmd) { + + # first expand out the entry to a command + my ($path, $fcmd) = search($main::localcmd, $cmd, "pl"); + ($path, $fcmd) = search($main::cmd, $cmd, "pl") if !$path || !$fcmd; + + # make sure it is loaded + $r = find_cmd_name($path, $fcmd); + } + return $r; } -sub eval_file { - my($self, $path, $cmdname) = @_; +# +# this bit of magic finds a command in the offered directory +sub find_cmd_name { + my $path = shift; + my $cmdname = shift; my $package = valid_package_name($cmdname); - my $filename = "$path/$cmdname"; + my $filename = "$path/$cmdname.pl"; my $mtime = -M $filename; - my @r; + + # return if we can't find it + $errstr = undef; + if (undef $mtime) { + $errstr = DXM::msg('e1'); + return undef; + } if(defined $Cache{$package}{mtime} && $Cache{$package}{mtime } <= $mtime) { #we have compiled this subroutine already, @@ -166,39 +453,50 @@ sub eval_file { #print STDERR "already compiled $package->handler\n"; ; } else { - local *FH; - open FH, $filename or die "open '$filename' $!"; - local($/) = undef; - my $sub = ; - close FH; + my $fh = new FileHandle; + if (!open $fh, $filename) { + $errstr = "Syserr: can't open '$filename' $!"; + return undef; + }; + local $/ = undef; + my $sub = <$fh>; + close $fh; #wrap the code into a subroutine inside our unique package - my $eval = qq{package $package; sub handler { $sub; }}; + my $eval = qq{ + sub $package + { + $sub + } }; + + if (isdbg('eval')) { + my @list = split /\n/, $eval; + my $line; + for (@list) { + dbg('eval', $_, "\n"); + } + } + { #hide our variables within this block my($filename,$mtime,$package,$sub); eval $eval; } + if ($@) { - $self->send("Eval err $@ on $package"); + print "\$\@ = $@"; + $errstr = $@; delete_package($package); - return undef; + } else { + #cache it unless we're cleaning out each time + $Cache{$package}{mtime} = $mtime; } - - #cache it unless we're cleaning out each time - $Cache{$package}{mtime} = $mtime; - } - - @r = eval {$package->handler;}; - if ($@) { - $self->send("Eval err $@ on cached $package"); - delete_package($package); - return undef; } - - #take a look if you want + #print Devel::Symdump->rnew($package)->as_string, $/; - return @r; + $package = "DXCommandmode::$package" if $package; + $package = undef if $errstr; + return $package; } 1;