X-Git-Url: http://www.dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXCommandmode.pm;h=aa4cb1a37a4fb287f9245612ec0b9d88e1c8c346;hb=cef696652d16bbeec53aca45234ea0b64f3496d3;hp=d39af559e625f135b6c5e1a032a3f0883b4ccb74;hpb=7432cb12ce865030c8b0315a30764e0088a59102;p=spider.git diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index d39af559..aa4cb1a3 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -17,13 +17,18 @@ use DXUser; use DXVars; use DXDebug; use DXM; +use DXLog; +use CmdAlias; +use FileHandle; use Carp; use strict; -use vars qw(%Cache %cmd_cache); +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 @@ -48,17 +53,18 @@ sub start 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->send($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->{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; +# $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"; @@ -67,8 +73,9 @@ sub start # issue a pc16 to everybody interested my $nchan = DXChannel->get($main::mycall); - my $pc16 = $nchan->pc16($cuser); - DXProt::broadcast_ak1a($pc16); + my @pc16 = DXProt::pc16($nchan, $cuser); + DXProt::broadcast_ak1a(@pc16); + Log('DXCommand', "$call connected"); } # @@ -80,36 +87,68 @@ sub normal my $user = $self->{user}; my $call = $self->{call}; my $cmdline = shift; + my @ans; + + # are we in stored state? + 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; + # special case only \n input => " " + if ($cmdline eq " ") { + $self->prompt(); + return; + } + + # 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; + # split the command line up into parts, the first part is the command + my ($cmd, $args) = $cmdline =~ /^([\w\/]+)\s*(.*)/o; - if ($cmd) { + if ($cmd) { - my ($path, $fcmd); + 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 @ans = $self->eval_file($path, $fcmd, $args) if $path && $fcmd; -# @ans = $self->eval_file($main::cmd, $cmd, $args) if !$ans[0]; - if ($ans[0]) { - shift @ans; - $self->send(@ans) if @ans > 0; - } else { - shift @ans; - if (@ans > 0) { - $self->msg('e2', @ans); - } else { - $self->msg('e1'); + # 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$@"); + } } } + } + + if ($ans[0]) { + shift @ans; + $self->send(@ans) if @ans > 0; } else { - $self->msg('e1'); + shift @ans; + if (@ans > 0) { + $self->send($self->msg('e2'), @ans); + } else { + $self->send($self->msg('e1')); + } } # send a prompt only if we are in a prompt state @@ -153,9 +192,10 @@ sub finish # issue a pc17 to everybody interested my $nchan = DXChannel->get($main::mycall); - my $pc17 = $nchan->pc17($ref); + my $pc17 = $nchan->pc17($self); DXProt::broadcast_ak1a($pc17); - + + Log('DXCommand', "$call disconnected"); $ref->del() if $ref; } @@ -167,7 +207,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] @@ -217,7 +258,7 @@ sub search my ($apath, $acmd) = split ',', $cmd_cache{$short_cmd}; if ($apath && $acmd) { dbg('command', "cached $short_cmd = ($apath, $acmd)\n"); - return ($apath, $acmd) if $apath; + return ($apath, $acmd); } # if not guess @@ -226,6 +267,7 @@ sub search my $curdir = $path; my $p; my $i; + my @lparts; for ($i = 0; $i < @parts; $i++) { my $p = $parts[$i]; @@ -242,14 +284,16 @@ sub search $curdir .= "/$l"; last; } - } else { # we are dealing with commands - next if !$l =~ /\.$suffix$/; # only look for .$suffix files + } 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)) { - $l =~ s/\.$suffix$//; # remove the suffix - 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"); + 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"); } } } @@ -282,7 +326,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; } @@ -292,16 +336,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); @@ -309,7 +380,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, @@ -317,50 +392,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;