X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXCommandmode.pm;h=43dab0535fd0a1430442be5c6f75b3e03ebccacb;hb=bbcb636f1bc71eb1426685ef64382ea42d27ecfb;hp=96ccc0a494aa872575064fee0a22cee274ad30c9;hpb=3634fba90a64fe488d237f438d9945d81158da52;p=spider.git diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index 96ccc0a4..43dab053 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -30,9 +30,11 @@ use AnnTalk; use WCY; use Sun; use Internet; +use Script; + use strict; -use vars qw(%Cache %cmd_cache $errstr %aliases $scriptbase $maxerrors %nothereslug); +use vars qw(%Cache %cmd_cache $errstr %aliases $scriptbase $maxerrors %nothereslug $maxbadcount); %Cache = (); # cache of dynamically loaded routine's mod times %cmd_cache = (); # cache of short names @@ -40,6 +42,8 @@ $errstr = (); # error string from eval %aliases = (); # aliases for (parts of) commands $scriptbase = "$main::root/scripts"; # the place where all users start scripts go $maxerrors = 20; # the maximum number of concurrent errors allowed before disconnection +$maxbadcount = 3; # no of bad words allowed before disconnection + use vars qw($VERSION $BRANCH); $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); @@ -59,7 +63,7 @@ sub new my $pkg = shift; my $call = shift; my @rout = $main::routeroot->add_user($call, Route::here(1)); - DXProt::route_pc16($DXProt::me, $main::routeroot, @rout) if @rout; + DXProt::route_pc16($main::me, $main::routeroot, @rout) if @rout; return $self; } @@ -75,6 +79,10 @@ sub start my $call = $self->{call}; my $name = $user->{name}; + # log it + my $host = $self->{conn}->{peerhost} || "unknown"; + Log('DXCommand', "$call connected from $host"); + $self->{name} = $name ? $name : $call; $self->send($self->msg('l2',$self->{name})); $self->send_file($main::motd) if (-e $main::motd); @@ -83,6 +91,8 @@ sub start $self->{lang} = $user->lang || $main::lang || 'en'; $self->{pagelth} = $user->pagelth || 20; $self->{priv} = 0 if $line =~ /^(ax|te)/; # set the connection priv to 0 - can be upgraded later + ($self->{width}) = $line =~ /width=(\d+)/; + $self->{width} = 80 unless $self->{width} && $self->{width} > 80; $self->{consort} = $line; # save the connection type # set some necessary flags on the user if they are connecting @@ -94,6 +104,7 @@ sub start $self->{wx} = $user->wantwx; $self->{dx} = $user->wantdx; $self->{logininfo} = $user->wantlogininfo; + $self->{ann_talk} = $user->wantann_talk; $self->{here} = 1; # get the filters @@ -111,18 +122,6 @@ sub start $user->qra(DXBearing::lltoqra($lat, $long)) if (defined $lat && defined $long); } - Log('DXCommand', "$call connected"); - - # send prompts and things - my $info = Route::cluster(); - $self->send("Cluster:$info"); - $self->send($self->msg('namee1')) if !$user->name; - $self->send($self->msg('qthe1')) if !$user->qth; - $self->send($self->msg('qll')) if !$user->qra || (!$user->lat && !$user->long); - $self->send($self->msg('hnodee1')) if !$user->qth; - $self->send($self->msg('m9')) if DXMsg::for_me($call); - $self->prompt; - # decide on echo if (!$user->wantecho) { $self->send_now('E', "0"); @@ -135,9 +134,25 @@ sub start my $lastoper = $user->lastoper || 0; my $homenode = $user->homenode || ""; if ($homenode eq $main::mycall && $lastoper + $DXUser::lastoperinterval < $main::systime) { - run_cmd($DXProt::me, "forward/opernam $call"); + run_cmd($main::me, "forward/opernam $call"); $user->lastoper($main::systime); } + + # run a script send the output to the punter + my $script = new Script(lc $call) || new Script('user_default'); + $script->run($self) if $script; + + # send cluster info + my $info = Route::cluster(); + $self->send("Cluster:$info"); + + # send prompts and things + $self->send($self->msg('namee1')) if !$user->name; + $self->send($self->msg('qthe1')) if !$user->qth; + $self->send($self->msg('qll')) if !$user->qra || (!$user->lat && !$user->long); + $self->send($self->msg('hnodee1')) if !$user->qth; + $self->send($self->msg('m9')) if DXMsg::for_me($call); + $self->prompt; } # @@ -207,18 +222,41 @@ sub normal $self->send($self->talk_prompt); } elsif ($self->{talklist} && @{$self->{talklist}}) { # send what has been said to whoever is in this person's talk list - for (@{$self->{talklist}}) { - $self->send_talks($_, $cmdline); + my @bad; + if (@bad = BadWords::check($cmdline)) { + $self->badcount(($self->badcount||0) + @bad); + Log('DXCommand', "$self->{call} swore: $cmdline"); + } else { + for (@{$self->{talklist}}) { + $self->send_talks($_, $cmdline); + } } $self->send($self->talk_prompt) if $self->{state} eq 'talk'; } else { # for safety $self->state('prompt'); } + } elsif (my $func = $self->{func}) { + no strict 'refs'; + my @ans; + if (ref $self->{edit}) { + eval { @ans = $self->{edit}->$func($self, $cmdline)}; + } else { + eval { @ans = &{$self->{func}}($self, $cmdline) }; + } + $self->send_ans("Syserr: on stored func $self->{func}", $@) if $@; + $self->send_ans(@ans); } else { $self->send_ans(run_cmd($self, $cmdline)); } - + + # check for excessive swearing + if ($self->{badcount} && $self->{badcount} >= $maxbadcount) { + Log('DXCommand', "$self->{call} logged out for excessive swearing"); + $self->disconnect; + return; + } + # send a prompt only if we are in a prompt state $self->prompt() if $self->{state} =~ /^prompt/o; } @@ -301,77 +339,54 @@ sub run_cmd my $cmdline = shift; my @ans; - if ($self->{func}) { - my $c = qq{ \@ans = $self->{func}(\$self, \$cmdline) }; - dbg("stored func cmd = $c\n") if isdbg('eval'); - eval $c; - if ($@) { - return ("Syserr: Eval err $errstr on stored func $self->{func}", $@); - } - } else { - return () if length $cmdline == 0; + return () if length $cmdline == 0; - # strip out // - $cmdline =~ s|//|/|og; + # strip out // + $cmdline =~ s|//|/|og; - # split the command line up into parts, the first part is the command - my ($cmd, $args) = split /\s+/, $cmdline, 2; - $args = "" unless defined $args; + # split the command line up into parts, the first part is the command + my ($cmd, $args) = split /\s+/, $cmdline, 2; + $args = "" unless defined $args; - if ($cmd) { + if ($cmd) { - my ($path, $fcmd); + my ($path, $fcmd); - dbg("cmd: $cmd") if isdbg('command'); + dbg("cmd: $cmd") if isdbg('command'); - # alias it if possible - my $acmd = CmdAlias::get_cmd($cmd); - if ($acmd) { - ($cmd, $args) = split /\s+/, "$acmd $args", 2; - $args = "" unless defined $args; - dbg("aliased cmd: $cmd $args") if isdbg('command'); - } + # alias it if possible + my $acmd = CmdAlias::get_cmd($cmd); + if ($acmd) { + ($cmd, $args) = split /\s+/, "$acmd $args", 2; + $args = "" unless defined $args; + dbg("aliased cmd: $cmd $args") if isdbg('command'); + } - # 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; + # 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; - if ($path && $cmd) { - dbg("path: $cmd cmd: $fcmd") if isdbg('command'); + if ($path && $cmd) { + dbg("path: $cmd cmd: $fcmd") if isdbg('command'); - my $package = find_cmd_name($path, $fcmd); - @ans = (0) if !$package ; + my $package = find_cmd_name($path, $fcmd); + return ($@) if $@; - if ($package) { - dbg("package: $package") if isdbg('command'); - my $c; - unless (exists $Cache{$package}->{'sub'}) { - $c = eval $Cache{$package}->{'eval'}; - if ($@) { - return DXDebug::shortmess($@); - } - $Cache{$package}->{'sub'} = $c; - } - $c = $Cache{$package}->{'sub'}; - eval { - @ans = &{$c}($self, $args); - }; - - if ($@) { - #cluck($@); - return (DXDebug::shortmess($@)); - }; - } + if ($package) { + no strict 'refs'; + dbg("package: $package") if isdbg('command'); + eval { @ans = &$package($self, $args) }; + return (DXDebug::shortmess($@)) if $@; + } + } else { + dbg("cmd: $cmd not found") if isdbg('command'); + if (++$self->{errors} > $maxerrors) { + $self->send($self->msg('e26')); + $self->disconnect; + return (); } else { - dbg("cmd: $cmd not found") if isdbg('command'); - if (++$self->{errors} > $maxerrors) { - $self->send($self->msg('e26')); - $self->disconnect; - return (); - } else { - return ($self->msg('e1')); - } + return ($self->msg('e1')); } } } @@ -423,6 +438,9 @@ sub disconnect { my $self = shift; my $call = $self->call; + + return if $self->{disconnecting}++; + delete $self->{senddbg}; my $uref = Route::User::get($call); @@ -435,7 +453,7 @@ sub disconnect } # issue a pc17 to everybody interested - DXProt::route_pc17($DXProt::me, $main::routeroot, @rout) if @rout; + DXProt::route_pc17($main::me, $main::routeroot, @rout) if @rout; # I was the last node visited $self->user->node($main::mycall); @@ -539,7 +557,7 @@ sub search $l = join '.', @lparts; # chop $dirfn; # remove trailing / $dirfn = "" unless $dirfn; - $cmd_cache{"$short_cmd"} = join(',', ($path, "$dirfn$l")); # cache it + $cmd_cache{$short_cmd} = join(',', ($path, "$dirfn$l")); # cache it dbg("got path: $path cmd: $dirfn$l\n") if isdbg('command'); return ($path, "$dirfn$l"); } @@ -552,7 +570,14 @@ sub search # clear the command name cache sub clear_cmd_cache { + no strict 'refs'; + + for (keys %Cache) { + undef *{$_}; + dbg("Undefining cmd $_") if isdbg('command'); + } %cmd_cache = (); + %Cache = (); } # @@ -568,39 +593,10 @@ sub clear_cmd_cache sub valid_package_name { my($string) = @_; - $string =~ s/([^A-Za-z0-9\/])/sprintf("_%2x",unpack("C",$1))/eg; - - #second pass only for words starting with a digit - $string =~ s|/(\d)|sprintf("/_%2x",unpack("C",$1))|eg; + $string =~ s|([^A-Za-z0-9_/])|sprintf("_%2x",unpack("C",$1))|eg; - #Dress it up as a real package name - $string =~ s/\//_/og; - return $string; -} - -# 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; + $string =~ s|/|_|g; + return "cmd_$string"; } # @@ -633,7 +629,7 @@ sub find_cmd_name { }; #wrap the code into a subroutine inside our unique package - my $eval = qq( sub { $sub } ); + my $eval = qq( sub $package { $sub } ); if (isdbg('eval')) { my @list = split /\n/, $eval; @@ -643,7 +639,19 @@ sub find_cmd_name { } } - $Cache{$package} = {mtime => $mtime, 'eval' => $eval }; + # get rid of any existing sub and try to compile the new one + no strict 'refs'; + + if (exists $Cache{$package}) { + dbg("Redefining $package") if isdbg('command'); + undef *$package; + } else { + dbg("Defining $package") if isdbg('command'); + } + eval $eval; + + $Cache{$package} = {mtime => $mtime }; + } return $package; @@ -696,6 +704,11 @@ sub announce my $text = shift; my ($filter, $hops); + if (!$self->{ann_talk} && $to ne $self->{call}) { + my $call = AnnTalk::is_talk_candidate($_[0], $text); + return if $call; + } + if ($self->{annfilter}) { ($filter, $hops) = $self->{annfilter}->it(@_ ); return unless $filter;