X-Git-Url: http://www.dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXCommandmode.pm;h=4ad01392dede6d82b09df9775084a0bf197247cd;hb=fa57f72c26032aae4c1a20358e829ba9afbf460c;hp=474d2c9c90d58ac1f8090ff3c75fd906650e8d90;hpb=1cf4bd14be226274d5deb05da8480ab91a5dac52;p=spider.git diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index 474d2c9c..4ad01392 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -16,13 +16,20 @@ use DXChannel; use DXUser; use DXVars; use DXDebug; +use DXM; +use DXLog; +use DXLogPrint; +use CmdAlias; +use FileHandle; +use Carp; use strict; +use vars qw(%Cache %cmd_cache $errstr %aliases); -#use vars qw( %Cache $last_dir_mtime @cmd); -my %Cache = (); # cache of dynamically loaded routine's mod times -my $last_dir_mtime = 0; # the last time one of the cmd dirs was modified -my @cmd = undef; # a list of commands+path pairs (in alphabetical order) +%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 @@ -41,65 +48,172 @@ sub new sub start { - my ($self, $line) = @_; + my ($self, $line, $sort) = @_; my $user = $self->{user}; my $call = $self->{call}; my $name = $user->{name}; - + $self->{name} = $name ? $name : $call; - $self->msg('l2',$self->{name}); + $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} = $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 normal { - my $self = shift; - my $user = $self->{user}; - my $call = $self->{call}; - my $cmdline = shift; - - # 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; + 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); + } + + # 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; +} - if ($cmd) { +# +# this is the thing that runs the command, it is done like this for the +# benefit of remote command execution +# - # first expand out the entry to a command - $cmd = search($cmd); +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$@"); + } + } + } + } - my @ans = $self->eval_file($main::localcmd, $cmd, $args); - @ans = $self->eval_file($main::cmd, $cmd, $args) if !$ans[0]; if ($ans[0]) { - shift @ans; - $self->send(@ans) if @ans > 0; + shift @ans; } else { - shift @ans; - if (@ans > 0) { - $self->msg('e2', @ans); - } else { - $self->msg('e1'); - } + shift @ans; + if (@ans > 0) { + unshift @ans, $self->msg('e2'); + } else { + @ans = $self->msg('e1'); + } } - } else { - $self->msg('e1'); - } - - # send a prompt only if we are in a prompt state - $self->prompt() if $self->{state} =~ /^prompt/o; + return (@ans); } # @@ -128,7 +242,22 @@ sub process # 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; } # @@ -139,7 +268,8 @@ sub prompt { my $self = shift; my $call = $self->{call}; - DXChannel::msg($self, 'pr', $call); + $self->send($self->msg('pr', $call)); + #DXChannel::msg($self, 'pr', $call); } # broadcast a message to all users [except those mentioned after buffer] @@ -178,10 +308,66 @@ sub get_all sub search { - my $short_cmd = shift; - return $short_cmd; # just return it for now + 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 = (); +} + # # the persistant execution of things from the command directories # @@ -201,7 +387,7 @@ sub valid_package_name { $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg; #Dress it up as a real package name - $string =~ s|/|_|g; + $string =~ s/\//_/og; return "Emb_" . $string; } @@ -211,16 +397,43 @@ sub delete_package { my ($stem, $leaf); no strict 'refs'; - $pkg = "DXChannel::$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}; + } } -sub eval_file { - my $self = shift; +# 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; +} + +# +# 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); @@ -228,7 +441,11 @@ sub eval_file { my $mtime = -M $filename; # return if we can't find it - return (0, DXM::msg('e1')) if !defined $mtime; + $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, @@ -236,50 +453,50 @@ sub eval_file { #print STDERR "already compiled $package->handler\n"; ; } else { - local *FH; - if (!open FH, $filename) { - return (0, "Syserr: can't open '$filename' $!"); + my $fh = new FileHandle; + if (!open $fh, $filename) { + $errstr = "Syserr: can't open '$filename' $!"; + return undef; }; - local($/) = undef; - my $sub = ; - close FH; + local $/ = undef; + my $sub = <$fh>; + close $fh; #wrap the code into a subroutine inside our unique package - my $eval = qq{package DXChannel; sub $package { $sub; }}; + my $eval = qq{ + sub $package + { + $sub + } }; + if (isdbg('eval')) { my @list = split /\n/, $eval; my $line; - foreach (@list) { + for (@list) { dbg('eval', $_, "\n"); } } - #print "eval $eval\n"; + { #hide our variables within this block my($filename,$mtime,$package,$sub); eval $eval; } + if ($@) { + print "\$\@ = $@"; + $errstr = $@; delete_package($package); - return (0, "Syserr: Eval err $@ on $package"); + } 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; } - my @r; - my $c = qq{ \@r = \$self->$package(\@_); }; - dbg('eval', "cluster cmd = $c\n"); - eval $c; ; - if ($@) { - delete_package($package); - return (0, "Syserr: Eval err $@ on cached $package"); - } - - #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;