X-Git-Url: http://gb7djk.dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FDXCommandmode.pm;h=0f80232ac8432636ef1d65a6f9a0bf609672e960;hb=b67b50de92dbf61ce939b42f7c74e30dc58eba41;hp=bce0255fd4750002963821575ccd462f5173ddda;hpb=8942c27356acc5d5f5a20134461bcf7e6bd6a044;p=spider.git diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index bce0255f..0f80232a 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -9,6 +9,8 @@ package DXCommandmode; +use POSIX; + @ISA = qw(DXChannel); use DXUtil; @@ -21,17 +23,23 @@ use DXLog; use DXLogPrint; use DXBearing; use CmdAlias; -use FileHandle; use Filter; -use Carp; +use Minimuf; +use DXDb; +use AnnTalk; +use WCY; +use Sun; +use Internet; use strict; -use vars qw(%Cache %cmd_cache $errstr %aliases); +use vars qw(%Cache %cmd_cache $errstr %aliases $scriptbase $maxerrors); %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 +$scriptbase = "$main::root/scripts"; # the place where all users start scripts go +$maxerrors = 20; # the maximum number of concurrent errors allowed before disconnection # # obtain a new connection this is derived from dxchannel @@ -40,7 +48,6 @@ $errstr = (); # error string from eval 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; } @@ -59,27 +66,56 @@ sub start $self->send($self->msg('l2',$self->{name})); $self->send_file($main::motd) if (-e $main::motd); $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} = $user->priv || 0; + $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->{consort} = $line; # save the connection type # set some necessary flags on the user if they are connecting - $self->{beep} = $self->{wwv} = $self->{wx} = $self->{talk} = $self->{ann} = $self->{here} = $self->{dx} = 1; - # $self->prompt() if $self->{state} =~ /^prompt/o; - + $self->{beep} = $user->wantbeep; + $self->{ann} = $user->wantann; + $self->{wwv} = $user->wantwwv; + $self->{wcy} = $user->wantwcy; + $self->{talk} = $user->wanttalk; + $self->{wx} = $user->wantwx; + $self->{dx} = $user->wantdx; + $self->{logininfo} = $user->wantlogininfo; + $self->{here} = 1; + + # get the filters + $self->{spotsfilter} = Filter::read_in('spots', $call, 0) || Filter::read_in('spots', 'user_default', 0); + $self->{wwvfilter} = Filter::read_in('wwv', $call, 0) || Filter::read_in('wwv', 'user_default', 0); + $self->{wcyfilter} = Filter::read_in('wcy', $call, 0) || Filter::read_in('wcy', 'user_default', 0); + $self->{annfilter} = Filter::read_in('ann', $call, 0) || Filter::read_in('ann', 'user_default', 0) ; + + # clean up qra locators + my $qra = $user->qra; + $qra = undef if ($qra && !DXBearing::is_qra($qra)); + unless ($qra) { + my $lat = $user->lat; + my $long = $user->long; + $user->qra(DXBearing::lltoqra($lat, $long)) if (defined $lat && defined $long); + } + # 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 + + # routing version + my $pref = Route::Node::get($main::mycall) or die "$main::mycall not allocated in Route database"; + $pref->add_user($call, Route::here($self->{here})); + dbg('route', "B/C PC16 on $main::mycall for: $call"); # issue a pc16 to everybody interested my $nchan = DXChannel->get($main::mycall); my @pc16 = DXProt::pc16($nchan, $cuser); - DXProt::broadcast_ak1a(@pc16); + for (@pc16) { + DXProt::broadcast_all_ak1a($_); + } Log('DXCommand', "$call connected"); - + # send prompts and things my $info = DXCluster::cluster(); $self->send("Cluster:$info"); @@ -87,12 +123,17 @@ sub start $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('msgnew')) if DXMsg::for_me($call); + $self->send($self->msg('m9')) if DXMsg::for_me($call); + $self->prompt; - # get the filters - $self->{spotfilter} = Filter::read_in('spots', $call); + # decide on echo + if (!$user->wantecho) { + $self->send_now('E', "0"); + $self->send($self->msg('echow')); + } + + $self->tell_login('loginu'); - $self->send($self->msg('pr', $call)); } # @@ -133,31 +174,112 @@ sub normal } 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); + } elsif ($self->{state} eq 'sysop') { + my $passwd = $self->{user}->passwd; + my @pw = split / */, $passwd; + if ($passwd) { + my @l = @{$self->{passwd}}; + my $str = "$pw[$l[0]].*$pw[$l[1]].*$pw[$l[2]].*$pw[$l[3]].*$pw[$l[4]]"; + if ($cmdline =~ /$str/) { + $self->{priv} = $self->{user}->priv; + } else { + $self->send($self->msg('sorry')); } - $self->{pagedata} = \@ans; - $self->state('page'); - $self->send($self->msg('page', scalar @ans)); } else { - for (@ans) { - s/\s+$//o; # why ????????? - $self->send($_); + $self->send($self->msg('sorry')); + } + delete $self->{passwd}; + $self->state('prompt'); + } elsif ($self->{state} eq 'talk') { + if ($cmdline =~ m{^(?:/EX|/ABORT)}i) { + for (@{$self->{talklist}}) { + $self->send_talks($_, $self->msg('talkend')); + } + $self->state('prompt'); + delete $self->{talklist}; + } elsif ($cmdline =~ m(^/\w+)) { + $cmdline =~ s(^/)(); + $self->send_ans(run_cmd($self, $cmdline)); + $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); } - } + $self->send($self->talk_prompt) if $self->{state} eq 'talk'; + } else { + # for safety + $self->state('prompt'); + } + } else { + $self->send_ans(run_cmd($self, $cmdline)); } # send a prompt only if we are in a prompt state $self->prompt() if $self->{state} =~ /^prompt/o; } +# send out the talk messages taking into account vias and connectivity +sub send_talks +{ + my ($self, $ent, $line) = @_; + + my ($to, $via) = $ent =~ /(\S+)>(\S+)/; + $to = $ent unless $to; + my $call = $via ? $via : $to; + my $clref = DXCluster->get_exact($call); + my $dxchan = $clref->dxchan if $clref; + if ($dxchan) { + $dxchan->talk($self->{call}, $to, $via, $line); + } else { + $self->send($self->msg('disc2', $via ? $via : $to)); + my @l = grep { $_ ne $ent } @{$self->{talklist}}; + if (@l) { + $self->{talklist} = \@l; + } else { + delete $self->{talklist}; + $self->state('prompt'); + } + } +} + +sub talk_prompt +{ + my $self = shift; + my @call; + for (@{$self->{talklist}}) { + my ($to, $via) = /(\S+)>(\S+)/; + $to = $_ unless $to; + push @call, $to; + } + return $self->msg('talkprompt', join(',', @call)); +} + +# +# send a load of stuff to a command user with page prompting +# and stuff +# + +sub send_ans +{ + my $self = shift; + + if ($self->{pagelth} && @_ > $self->{pagelth}) { + my $i; + for ($i = $self->{pagelth}; $i-- > 0; ) { + my $line = shift @_; + $line =~ s/\s+$//o; # why am having to do this? + $self->send($line); + } + $self->{pagedata} = [ @_ ]; + $self->state('page'); + $self->send($self->msg('page', scalar @_)); + } else { + for (@_) { + $self->send($_) if $_; + } + } +} # # this is the thing that runs the command, it is done like this for the # benefit of remote command execution @@ -176,7 +298,7 @@ sub run_cmd dbg('eval', "stored func cmd = $c\n"); eval $c; if ($@) { - return (1, "Syserr: Eval err $errstr on stored func $self->{func}"); + return ("Syserr: Eval err $errstr on stored func $self->{func}", $@); } } else { @@ -186,7 +308,8 @@ sub run_cmd $cmdline =~ s|//|/|og; # split the command line up into parts, the first part is the command - my ($cmd, $args) = $cmdline =~ /^([\S\/]+)\s*(.*)/o; + my ($cmd, $args) = split /\s+/, $cmdline, 2; + $args = "" unless defined $args; if ($cmd) { @@ -197,7 +320,8 @@ sub run_cmd # alias it if possible my $acmd = CmdAlias::get_cmd($cmd); if ($acmd) { - ($cmd, $args) = "$acmd $args" =~ /^([\w\/]+)\s*(.*)/o; + ($cmd, $args) = split /\s+/, "$acmd $args", 2; + $args = "" unless defined $args; dbg('command', "aliased cmd: $cmd $args"); } @@ -213,29 +337,45 @@ sub run_cmd if ($package) { dbg('command', "package: $package"); + 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); + }; - my $c = qq{ \@ans = $package(\$self, \$args) }; - dbg('eval', "cluster cmd = $c\n"); - eval $c; if ($@) { - @ans = (0, "Syserr: Eval err cached $package\n$@"); - } + #cluck($@); + return (DXDebug::shortmess($@)); + }; } } else { dbg('command', "cmd: $cmd not found"); - @ans = (0); + if (++$self->{errors} > $maxerrors) { + $self->send($self->msg('e26')); + $self->disconnect; + return (); + } else { + return ($self->msg('e1')); + } } } } - if ($ans[0]) { - shift @ans; + my $ok = shift @ans; + if ($ok) { + delete $self->{errors}; } else { - shift @ans; - if (@ans > 0) { - unshift @ans, $self->msg('e2'); - } else { - @ans = $self->msg('e1'); + if (++$self->{errors} > $maxerrors) { + $self->send($self->msg('e26')); + $self->disconnect; + return (); } } return (@ans); @@ -265,33 +405,39 @@ sub process # # finish up a user context # -sub finish +sub disconnect { my $self = shift; my $call = $self->call; - # log out text - if (-e "$main::data/logout") { - open(I, "$main::data/logout") or confess; - my @in = ; - close(I); - $self->send_now('D', @in); - sleep(1); + # reset the redirection of messages back to 'normal' if we are the sysop + if ($call eq $main::myalias) { + my $node = DXNode->get($main::mycall) or die "$main::mycall not allocated in DXNode database"; + $node->dxchan($DXProt::me); } - if ($call eq $main::myalias) { # unset the channel if it is us really - my $node = DXNode->get($main::mycall); - $node->{dxchan} = 0; + my $pref = Route::Node::get($main::mycall); + if ($pref) { + my @rout = $pref->del_user($main::mycall); + dbg('route', "B/C PC17 on $main::mycall for: $call"); } - my $ref = DXCluster->get_exact($call); - + + # I was the last node visited + $self->user->node($main::mycall); + # issue a pc17 to everybody interested my $nchan = DXChannel->get($main::mycall); my $pc17 = $nchan->pc17($self); - DXProt::broadcast_ak1a($pc17); - + DXProt::broadcast_all_ak1a($pc17); + + # send info to all logged in thingies + $self->tell_login('logoutu'); + Log('DXCommand', "$call disconnected"); + my $ref = DXCluster->get_exact($call); $ref->del() if $ref; + + $self->SUPER::disconnect; } # @@ -301,7 +447,7 @@ sub finish sub prompt { my $self = shift; - $self->send($self->msg($self->here ? 'pr' : 'pr2', $self->call)); + $self->send($self->msg($self->here ? 'pr' : 'pr2', $self->call, cldate($main::systime), ztime($main::systime))); } # broadcast a message to all users [except those mentioned after buffer] @@ -334,6 +480,14 @@ sub get_all return @out; } +# run a script for this user +sub run_script +{ + my $self = shift; + my $silent = shift || 0; + +} + # # search for the command in the cache of short->long form commands # @@ -424,22 +578,7 @@ sub valid_package_name { #Dress it up as a real package name $string =~ s/\//_/og; - return "Emb_" . $string; -} - -#borrowed from Safe.pm -sub delete_package { - my $pkg = shift; - my ($stem, $leaf); - - no strict 'refs'; - $pkg = "DXCommandmode::$pkg\::"; # expand to full symbol table name - ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/; - - if ($stem && $leaf) { - my $stem_symtab = *{$stem}{HASH}; - delete $stem_symtab->{$leaf}; - } + return $string; } # find a cmd reference @@ -483,25 +622,21 @@ sub find_cmd_name { return undef; } - if(defined $Cache{$package}{mtime} && $Cache{$package}{mtime } <= $mtime) { + if(defined $Cache{$package}->{mtime} &&$Cache{$package}->{mtime} <= $mtime) { #we have compiled this subroutine already, #it has not been updated on disk, nothing left to do #print STDERR "already compiled $package->handler\n"; ; } else { - delete_package($package) if defined $Cache{$package}{mtime}; - - my $fh = new FileHandle; - if (!open $fh, $filename) { + + my $sub = readfilestr($filename); + unless ($sub) { $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{ sub $package { $sub } }; + my $eval = qq( sub { $sub } ); if (isdbg('eval')) { my @list = split /\n/, $eval; @@ -511,27 +646,32 @@ sub find_cmd_name { } } - { - #hide our variables within this block - my($filename,$mtime,$package,$sub); - eval $eval; - } - - if ($@) { - print "\$\@ = $@"; - $errstr = $@; - delete_package($package); - } else { - #cache it unless we're cleaning out each time - $Cache{$package}{'mtime'} = $mtime; - } + $Cache{$package} = {mtime => $mtime, 'eval' => $eval }; } - - #print Devel::Symdump->rnew($package)->as_string, $/; - $package = "DXCommandmode::$package" if $package; - $package = undef if $errstr; + return $package; } +# send a talk message here +sub talk +{ + my ($self, $from, $to, $via, $line) = @_; + $line =~ s/\\5E/\^/g; + $self->send("$to de $from: $line") if $self->{talk}; + Log('talk', $to, $from, $main::mycall, $line); +} + +# send an announce +sub announce +{ + +} + +# send a dx spot +sub dx_spot +{ + +} + 1; __END__