From 4b207544da78b182bd12e94eab01451694749012 Mon Sep 17 00:00:00 2001 From: Dirk Koopman Date: Fri, 7 Jan 2022 23:47:56 +0000 Subject: [PATCH] mega-merge of major parts of mojo The point of this is to make it easier to maintain both branches. DXProt (DXProtHandle has already been copied) route/* DXChannel DXCommandmode and console.pl have been either copied wholesale, where necessary, modified to use the old Msg based networking stack. --- Changes | 2 + cmd/announce.pl | 4 +- cmd/chat.pl | 2 +- cmd/dx.pl | 103 +++++++++++-------- cmd/links.pl | 29 +++--- cmd/reply.pl | 2 +- cmd/send.pl | 2 +- cmd/show/cluster.pl | 11 ++- cmd/spoof.pl | 3 +- cmd/talk.pl | 2 +- cmd/unset/register.pl | 2 +- cmd/who.pl | 8 +- cmd/wx.pl | 2 +- perl/Console.pm | 43 ++++---- perl/DXChannel.pm | 140 +++++++++++++++----------- perl/DXCommandmode.pm | 105 +++++++++++++------- perl/DXProt.pm | 3 + perl/Messages | 35 ++++--- perl/Route.pm | 18 +++- perl/Route/Node.pm | 15 ++- perl/Route/User.pm | 7 -- perl/cluster.pl | 5 +- perl/console.pl | 224 ++++++++++++++++++++++-------------------- perl/watchdbg | 33 ++++--- 24 files changed, 475 insertions(+), 325 deletions(-) diff --git a/Changes b/Changes index 8c8829e3..de0f78c9 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,5 @@ +07Jan22======================================================================= +1. Backport console.pl from the Mojo Branch. 06Jan22======================================================================= 1. Backport various Mojo branch "security" fixes. 12Dec21======================================================================= diff --git a/cmd/announce.pl b/cmd/announce.pl index 7f52a461..9065993b 100644 --- a/cmd/announce.pl +++ b/cmd/announce.pl @@ -17,10 +17,12 @@ my ($self, $line) = @_; #$DB::single = 1; +my $addr = $self->hostname || '127.0.0.1'; +Log('cmd', "$self->{call}|$addr|announce|$line"); my @f = split /\s+/, $line; return (1, $self->msg('e5')) if $self->remotecmd || $self->inscript; return (1, $self->msg('e9')) if !@f; -return (1, $self->msg('e28')) unless $self->registered; +return (1, $self->msg('e28')) unless $self->isregistered; my $sort = uc $f[0]; my $to = '*'; diff --git a/cmd/chat.pl b/cmd/chat.pl index b65ca928..13018765 100644 --- a/cmd/chat.pl +++ b/cmd/chat.pl @@ -13,7 +13,7 @@ my ($self, $line) = @_; my @f = split /\s+/, $line, 2; return (1, $self->msg('e5')) if $self->remotecmd || $self->inscript; return (1, $self->msg('e34')) unless @f >= 1; -return (1, $self->msg('e28')) unless $self->registered; +return (1, $self->msg('e28')) unless $self->isregistered; my $target = uc $f[0]; diff --git a/cmd/dx.pl b/cmd/dx.pl index 18687a68..a5d3b425 100644 --- a/cmd/dx.pl +++ b/cmd/dx.pl @@ -16,8 +16,16 @@ my $freq; my @out; my $valid = 0; my $localonly; +my $oline = $line; + +#$DB::single=1; + return (1, $self->msg('e5')) if $self->remotecmd || $self->inscript; -return (1, $self->msg('e28')) unless $self->registered; +return (1, $self->msg('e28')) unless $self->isregistered; + + +my $addr = $self->hostname || '127.0.0.1'; +Log('cmd', "$self->{call}|$addr|dx|$line"); my @bad; if (@bad = BadWords::check($line)) { @@ -34,14 +42,27 @@ return (1, $self->msg('dx2')) unless @f >= 2; # can be in any order if ($f[0] =~ /^by$/i) { - return (1, $self->msg('e5')) unless $main::allowdxby || $self->priv; + return (1, $self->msg('e5')) unless $main::allowdxby || $self->priv > 1; $spotter = uc $f[1]; - $line =~ s/\s*$f[0]\s+$f[1]\s+//; -# $line = $f[2]; - @f = split /\s+/, $line, 3; + $line =~ s/^\s*$f[0]\s+$f[1]\s+//; + @f = split /\s+/, $line, 3; return (1, $self->msg('dx2')) unless @f >= 2; } +my $ipaddr; +@f = split /\s+/, $line, 3; +if ($f[0] eq 'ip') { + return (1, $self->msg('e5')) unless $spotter && $self->priv > 1; + if (is_ipaddr($f[1])) { + $ipaddr = $f[1]; + } else { + return (1, $self->msg('dx4', $f[1])); + } + $line =~ s/^\s*$f[0]\s+$f[1]\s+//; + @f = split /\s+/, $line, 3; +} + + # get the freq and callsign either way round if (is_freq($f[1]) && $f[0] =~ m{^[\w\d]+(?:/[\w\d]+){0,2}$}) { $spotted = uc $f[0]; @@ -52,28 +73,39 @@ if (is_freq($f[1]) && $f[0] =~ m{^[\w\d]+(?:/[\w\d]+){0,2}$}) { } else { return (1, $self->msg('dx3')); } +$line =~ s/^\s*$f[0]//; +$line =~ s/^\s*$f[1]//; +$line =~ unpad($line); +$line =~ s/\t+/ /g; # do this here because it needs to be stopped ASAP! +$line ||= ' '; + +if ($self->conn && $self->conn->peerhost) { + $ipaddr ||= $addr; # force a PC61 +} elsif ($self->inscript) { + $ipaddr = "script"; +} # check some other things # remove ssid from calls -my $callnoid = $self->call; -$callnoid =~ s/-\d+$//; -my $spotternoid = $spotter; -$spotternoid =~ s/-\d+$//; +my $spotternoid = basecall($spotter); +my $callnoid = basecall($self->{call}); + +#$DB::single = 1; + if ($DXProt::baddx->in($spotted)) { $localonly++; } -if ($DXProt::badspotter->in($callnoid)) { - LogDbg('DXCommand', "$self->{call} badspotter with $callnoid ($line)"); - $localonly++; -} -if ($callnoid ne $spotternoid && $DXProt::badspotter->in($spotternoid)) { - LogDbg('DXCommand', "$self->{call} badspotter with $spotternoid ($line)"); +if ($DXProt::badspotter->in($spotternoid)) { + LogDbg('DXCommand', "badspotter $spotternoid as $spotter ($oline) from $addr"); $localonly++; } -# make line the rest of the line -$line = $f[2] || " "; -@f = split /\s+/, $line; +dbg "spotter $spotternoid/$callnoid\n"; + +if (($spotted =~ /$spotternoid/ || $spotted =~ /$callnoid/) && $freq < $Spot::minselfspotqrg) { + LogDbg('DXCommand', "$spotternoid/$callnoid trying to self spot below ${Spot::minselfspotqrg}KHz ($oline) from $addr, not passed on to cluster"); + $localonly++; +} # bash down the list of bands until a valid one is reached my $bandref; @@ -120,20 +152,13 @@ if ($spotted le ' ') { return (1, @out) unless $valid; -my $ipaddr; - -if ($self->conn && $self->conn->peerhost) { - my $addr = $self->conn->peerhost; - $ipaddr = $addr unless !is_ipaddr($addr) || $addr =~ /^127\./ || $addr =~ /^::[0-9a-f]+$/; -} elsif ($self->inscript) { - $ipaddr = "script"; -} - # Store it here (but only if it isn't baddx) my $t = (int ($main::systime/60)) * 60; -return (1, $self->msg('dup')) if Spot::dup($freq, $spotted, $t, $line, $spotter); +return (1, $self->msg('dup')) if Spot::dup($freq, $spotted, $t, $line, $spotter, $main::mycall); my @spot = Spot::prepare($freq, $spotted, $t, $line, $spotter, $main::mycall, $ipaddr); +#$DB::single = 1; + if ($freq =~ /^69/ || $localonly) { # heaven forfend that we get a 69Mhz band :-) @@ -142,18 +167,20 @@ if ($freq =~ /^69/ || $localonly) { } $self->dx_spot(undef, undef, @spot); + return (1); } else { - if (@spot) { - # store it + # send orf to the users + $ipaddr ||= $main::mycall; # emergency backstop + my $spot = DXProt::pc61($spotter, $freq, $spotted, unpad($line), $ipaddr); + + $self->dx_spot(undef, undef, @spot); + if ($self->isslugged) { + push @{$self->{sluggedpcs}}, [61, $spot, \@spot]; + } else { + # store in spots database Spot::add(@spot); - - # send orf to the users - if ($ipaddr) { - DXProt::send_dx_spot($self, DXProt::pc61($spotter, $freq, $spotted, $line, $ipaddr), @spot); - } else { - DXProt::send_dx_spot($self, DXProt::pc11($spotter, $freq, $spotted, $line), @spot); - } + DXProt::send_dx_spot($self, $spot, @spot); } } @@ -161,5 +188,3 @@ return (1, @out); - - diff --git a/cmd/links.pl b/cmd/links.pl index 8856ba27..ed4082ff 100644 --- a/cmd/links.pl +++ b/cmd/links.pl @@ -15,20 +15,22 @@ my $dxchan; my @out; my $nowt = time; -push @out, " Ave Obs Ping Next Filters"; -push @out, " Callsign Type Started RTT Count Int. Ping Iso? In Out PC92? Address"; +push @out, " Ave Obs Ping Next Filters"; +push @out, " Callsign Type Started Uptime RTT Count Int. Ping Iso? In Out PC92? Address"; -foreach $dxchan ( sort {$a->call cmp $b->call} DXChannel::get_all_nodes ) { - my $call = $dxchan->call(); +foreach $dxchan ( sort {$a->call cmp $b->call} DXChannel::get_all ) { next if $dxchan == $main::me; + next unless $dxchan->is_node || $dxchan->is_rbn; + my $call = $dxchan->call(); my $t = cldatetime($dxchan->startt); my $sort; my $name = $dxchan->user->name || " "; my $obscount = $dxchan->nopings; my $pingint = $dxchan->pingint; my $lastt = $dxchan->lastping ? ($dxchan->pingint - ($nowt - $dxchan->lastping)) : $pingint; - my $ping = $dxchan->is_node && $dxchan != $main::me ? sprintf("%8.2f",$dxchan->pingave) : ""; - my $iso = $dxchan->isolate ? 'Y' :' '; + my $ping = sprintf("%7.2f", $dxchan->pingave || 0); + my $iso = $dxchan->isolate ? 'Y' : ' '; + my $uptime = difft($dxchan->startt, 1); my ($fin, $fout, $pc92) = (' ', ' ', ' '); if ($dxchan->do_pc9x) { $pc92 = 'Y'; @@ -41,27 +43,28 @@ foreach $dxchan ( sort {$a->call cmp $b->call} DXChannel::get_all_nodes ) { $fout = $dxchan->routefilter =~ /node_default/ ? 'D' : 'Y'; } } - unless ($pingint) { + unless ($pingint && $ping) { $lastt = 0; - $ping = " "; + $ping = ' '; + $obscount = ' '; } - $sort = 'ANEA' if $dxchan->is_aranea; $sort = "DXSP" if $dxchan->is_spider; $sort = "CLX " if $dxchan->is_clx; $sort = "DXNT" if $dxchan->is_dxnet; $sort = "AR-C" if $dxchan->is_arcluster; $sort = "AK1A" if $dxchan->is_ak1a; + $sort = "RBN " if $dxchan->is_rbn; my $ipaddr; - if ($dxchan->conn->peerhost) { - my $addr = $dxchan->conn->peerhost; - $ipaddr = $addr if is_ipaddr($addr); + my $addr = $dxchan->hostname; + if ($addr) { + $ipaddr = $addr if is_ipaddr($addr); $ipaddr = 'local' if $addr =~ /^127\./ || $addr =~ /^::[0-9a-f]+$/; } $ipaddr = 'ax25' if $dxchan->conn->ax25; - push @out, sprintf "%10s $sort $t$ping $obscount %5d %5d $iso $fin $fout $pc92 $ipaddr", $call, $pingint, $lastt; + push @out, sprintf "%10s $sort $t%13s$ping $obscount %5d %5d $iso $fin $fout $pc92 $ipaddr", $call, $uptime ,$pingint, $lastt; } return (1, @out) diff --git a/cmd/reply.pl b/cmd/reply.pl index 292316b5..22f04b85 100644 --- a/cmd/reply.pl +++ b/cmd/reply.pl @@ -67,7 +67,7 @@ if ($self->state eq "prompt") { @extra = (); } - return (1, $self->msg('e28')) unless $self->registered || $to eq $main::myalias; + return (1, $self->msg('e28')) unless $self->isregistered || $to eq $main::myalias; $loc->{to} = [ $to, @extra ]; # to is an array $loc->{subject} = $oref->subject; diff --git a/cmd/send.pl b/cmd/send.pl index 08b2aa43..0fb91e10 100644 --- a/cmd/send.pl +++ b/cmd/send.pl @@ -39,7 +39,7 @@ if ($self->state eq "prompt") { # any thing after send? return (1, $self->msg('e6')) if !@f; - return (1, $self->msg('e28')) unless $self->registered || uc $f[0] eq $main::myalias; + return (1, $self->msg('e28')) unless $self->isregistered || uc $f[0] eq $main::myalias; while (@f) { my $f = uc shift @f; diff --git a/cmd/show/cluster.pl b/cmd/show/cluster.pl index 066ef7bf..d61eaa84 100644 --- a/cmd/show/cluster.pl +++ b/cmd/show/cluster.pl @@ -1,4 +1,13 @@ # # show some statistics # -return (1, Route::cluster() ); + +my $self = shift; + +my ($nodes, $tot, $users, $maxlocalusers, $maxusers, $uptime, $localnodes) = Route::cluster(); + +$localnodes = $main::routeroot->nodes; +$users = $main::routeroot->users; +$uptime = difft($main::starttime, ' '); + +return (1, $self->msg('cluster', $localnodes, $nodes, $users, $tot, $maxlocalusers, $maxusers, $uptime)); diff --git a/cmd/spoof.pl b/cmd/spoof.pl index e0194a11..d4be673f 100644 --- a/cmd/spoof.pl +++ b/cmd/spoof.pl @@ -35,7 +35,8 @@ unless ($user) { # set up basic environment $self->call($call); $self->user($user); -Log('DXCommand', "spoof '$newline' as $call by $mycall"); +my $addr = $self->hostname || '127.0.0.1'; +Log('cmd', "$self->{call}|$addr|spoof|$line"); my @in = $self->run_cmd($newline); push @out, map {"spoof $call: $_"} @in; $self->call($mycall); diff --git a/cmd/talk.pl b/cmd/talk.pl index acd2eba5..dae38e24 100644 --- a/cmd/talk.pl +++ b/cmd/talk.pl @@ -33,7 +33,7 @@ return (1, $self->msg('e8')) unless $to; $to = uc $to; return (1, $self->msg('e22', $to)) unless is_callsign($to); -return (1, $self->msg('e28')) unless $self->registered || $to eq $main::myalias; +return (1, $self->msg('e28')) unless $self->isregistered || $to eq $main::myalias; $via = uc $via if $via; my $call = $via || $to; diff --git a/cmd/unset/register.pl b/cmd/unset/register.pl index a0c36d78..c18ac3c7 100644 --- a/cmd/unset/register.pl +++ b/cmd/unset/register.pl @@ -17,7 +17,7 @@ if ($self->priv < 9) { Log('DXCommand', $self->call . " attempted to unregister @args"); return (1, $self->msg('e5')); } -return (1, $self->msg('reginac')) unless $main::reqreg; +#return (1, $self->msg('reginac')) unless $main::reqreg; foreach $call (@args) { $call = uc $call; diff --git a/cmd/who.pl b/cmd/who.pl index b068c586..4371b08d 100644 --- a/cmd/who.pl +++ b/cmd/who.pl @@ -19,19 +19,23 @@ foreach $dxchan ( sort {$a->call cmp $b->call} DXChannel::get_all ) { my $type = $dxchan->is_node ? "NODE" : "USER"; my $sort = " "; if ($dxchan->is_node) { - $sort = 'ANEA' if $dxchan->is_aranea; $sort = "DXSP" if $dxchan->is_spider; $sort = "CLX " if $dxchan->is_clx; $sort = "DXNT" if $dxchan->is_dxnet; $sort = "AR-C" if $dxchan->is_arcluster; $sort = "AK1A" if $dxchan->is_ak1a; + } else { + $sort = "LOCL" if $dxchan->conn->isa('IntMsg'); + $sort = "WEB " if $dxchan->is_web; + $sort = "EXT " if $dxchan->conn->isa('ExtMsg'); + $type = "RBN " if $dxchan->is_rbn; # Yes, this is NOT a typo } my $name = $dxchan->user->name || " "; my $ping = $dxchan->is_node && $dxchan != $main::me ? sprintf("%5.2f", $dxchan->pingave) : " "; my $conn = $dxchan->conn; my $ip = ''; if ($conn) { - $ip = $conn->{peerhost} if exists $conn->{peerhost}; + $ip = $dxchan->hostname; $ip = "AGW Port ($conn->{agwport})" if exists $conn->{agwport}; } push @out, sprintf "%10s $type $sort $t %-10.10s $ping $ip", $call, $name; diff --git a/cmd/wx.pl b/cmd/wx.pl index 73e2e566..57147190 100644 --- a/cmd/wx.pl +++ b/cmd/wx.pl @@ -23,7 +23,7 @@ my $t = ztime(time); my $tonode; my $via; return (1, $self->msg('e5')) if $self->remotecmd || $self->inscript; -return (1, $self->msg('e28')) unless $self->registered; +return (1, $self->msg('e28')) unless $self->isregistered; if ($sort eq "FULL") { $line =~ s/^$f[0]\s+//; # remove it diff --git a/perl/Console.pm b/perl/Console.pm index a6dc6613..9dfacfb6 100644 --- a/perl/Console.pm +++ b/perl/Console.pm @@ -39,33 +39,34 @@ if ($ENV{'TERM'} =~ /(xterm|ansi)/) { $background = COLOR_WHITE(); $mycallcolor = COLOR_PAIR(1); @colors = ( - [ '^DX de [\-A-Z0-9]+:\s+([57][01]\d\d\d\.|\d\d\d\d\d\d+.)', COLOR_PAIR(1) ], - [ '^DX', COLOR_PAIR(5) ], - [ '^To', COLOR_PAIR(3) ], - [ '^(?:WWV|WCY)', COLOR_PAIR(4) ], - [ '^[-A-Z0-9]+ de [-A-Z0-9]+ \d\d-\w\w\w-\d\d\d\d \d\d\d\dZ', COLOR_PAIR(0) ], - [ '^[-A-Z0-9]+ de [-A-Z0-9]+ ', COLOR_PAIR(6) ], - [ '^WX', COLOR_PAIR(3) ], - [ '^(User|Node|Buddy)\b', COLOR_PAIR(8) ], - [ '^New mail', A_BOLD|COLOR_PAIR(5) ], - - ); + [ '^[-A-Z0-9]+ de [-A-Z0-9]+ \d\d-\w\w\w-\d\d\d\d \d\d\d\dZ', COLOR_PAIR(0) ], + [ '^DX de [\-A-Z0-9]+:\s+([57][01]\d\d\d\.|\d\d\d\d\d\d+.)', COLOR_PAIR(1) ], + [ '-#', COLOR_PAIR(2) ], + [ '^To', COLOR_PAIR(3) ], + [ '^WX', COLOR_PAIR(3) ], + [ '^(?:WWV|WCY)', COLOR_PAIR(4) ], + [ '^DX', COLOR_PAIR(5) ], + [ '^[-A-Z0-9]+ de [-A-Z0-9]+ ', COLOR_PAIR(6) ], + [ '^(User|Node|Buddy)\b', COLOR_PAIR(8) ], + [ '^New mail', A_BOLD|COLOR_PAIR(5) ], + ); } if ($ENV{'TERM'} =~ /(console|linux)/) { $foreground = COLOR_WHITE(); $background = COLOR_BLACK(); $mycallcolor = COLOR_PAIR(1); @colors = ( - [ '^DX de [\-A-Z0-9]+:\s+([57][01]\d\d\d\.|\d\d\d\d\d\d+.)', COLOR_PAIR(1) ], - [ '^DX', COLOR_PAIR(4) ], - [ '^To', COLOR_PAIR(3) ], - [ '^(?:WWV|WCY)', COLOR_PAIR(5) ], - [ '^[-A-Z0-9]+ de [-A-Z0-9]+ \d\d-\w\w\w-\d\d\d\d \d\d\d\dZ', COLOR_PAIR(0) ], - [ '^[-A-Z0-9]+ de [-A-Z0-9]+ ', COLOR_PAIR(6) ], - [ '^WX', COLOR_PAIR(3) ], - [ '^(User|Node)\b', A_BOLD|COLOR_PAIR(8) ], - [ '^New mail', A_BOLD|COLOR_PAIR(5) ], - ); + [ '^DX de [\-A-Z0-9]+:\s+([57][01]\d\d\d\.|\d\d\d\d\d\d+.)', COLOR_PAIR(1) ], + [ '^-#:', COLOR_PAIR(2) ], + [ '^DX', COLOR_PAIR(4) ], + [ '^To', COLOR_PAIR(3) ], + [ '^(?:WWV|WCY)', COLOR_PAIR(5) ], + [ '^[-A-Z0-9]+ de [-A-Z0-9]+ \d\d-\w\w\w-\d\d\d\d \d\d\d\dZ', COLOR_PAIR(0) ], + [ '^[-A-Z0-9]+ de [-A-Z0-9]+ ', COLOR_PAIR(6) ], + [ '^WX', COLOR_PAIR(3) ], + [ '^(User|Node)\b', A_BOLD|COLOR_PAIR(8) ], + [ '^New mail', A_BOLD|COLOR_PAIR(5) ], + ); } diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index f2a1638c..c2358c3d 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -19,7 +19,7 @@ # firstly and OO about ninthly (if you don't like the design and you can't # improve it with better OO and thus make it smaller and more efficient, then tough). # -# Copyright (c) 1998-2000 - Dirk Koopman G1TLH +# Copyright (c) 1998-2016 - Dirk Koopman G1TLH # # # @@ -80,12 +80,14 @@ $count = 0; wcyfilter => '5,WCY Filt-out', spotsfilter => '5,Spot Filt-out', routefilter => '5,Route Filt-out', + rbnfilter => '5,RBN Filt-out', pc92filter => '5,PC92 Route Filt-out', inannfilter => '5,Ann Filt-inp', inwwvfilter => '5,WWV Filt-inp', inwcyfilter => '5,WCY Filt-inp', inspotsfilter => '5,Spot Filt-inp', inroutefilter => '5,Route Filt-inp', + inrbnfilter => '5,RBN Filt-inp', inpc92filter => '5,PC92 Route Filt-inp', passwd => '9,Passwd List,yesno', pingint => '5,Ping Interval ', @@ -125,6 +127,9 @@ $count = 0; inqueue => '9,Input Queue,parray', next_pc92_update => '9,Next PC92 Update,atime', next_pc92_keepalive => '9,Next PC92 KeepAlive,atime', + hostname => '0,Hostname', + isslugged => '9,Still Slugged,yesno', + sluggedpcs => '9,Slugged PCxx Queue,parray', ); $maxerrors = 20; # the maximum number of concurrent errors allowed before disconnection @@ -161,20 +166,19 @@ sub alloc $self->{sort} = $user->sort; $self->{width} = $user->width; } - $self->{startt} = $self->{t} = time; + $self->{startt} = $self->{t} = $main::systime; $self->{state} = 0; $self->{oldstate} = 0; $self->{lang} = $main::lang if !$self->{lang}; $self->{func} = ""; $self->{width} ||= 80; - # add in all the dxcc, itu, zone info my @dxcc = Prefix::extract($call); if (@dxcc > 0) { $self->{dxcc} = $dxcc[1]->dxcc; $self->{itu} = $dxcc[1]->itu; - $self->{cq} = $dxcc[1]->cq; + $self->{cq} = $dxcc[1]->cq; } $self->{inqueue} = []; @@ -216,6 +220,7 @@ sub rec if (defined $msg) { push @{$self->{inqueue}}, $msg; } + $self->process_one; } # obtain a channel object by callsign [$obj = DXChannel::get($call)] @@ -301,69 +306,70 @@ sub del # is it a bbs sub is_bbs { - my $self = shift; - return $self->{'sort'} eq 'B'; + return $_[0]->{sort} eq 'B'; } sub is_node { - my $self = shift; - return $self->{'sort'} =~ /[ACRSXW]/; + return $_[0]->{sort} =~ /^[ACRSX]$/; } # is it an ak1a node ? sub is_ak1a { - my $self = shift; - return $self->{'sort'} eq 'A'; + return $_[0]->{sort} eq 'A'; } # is it a user? sub is_user { - my $self = shift; - return $self->{'sort'} eq 'U'; + return $_[0]->{sort} =~ /^[UW]$/; } # is it a clx node sub is_clx { - my $self = shift; - return $self->{'sort'} eq 'C'; + return $_[0]->{sort} eq 'C'; } -# it is Aranea -sub is_aranea +# it is a Web connected user +sub is_web { - my $self = shift; - return $self->{'sort'} eq 'W'; + return $_[0]->{sort} eq 'W'; } # is it a spider node sub is_spider { - my $self = shift; - return $self->{'sort'} eq 'S'; + return $_[0]->{sort} eq 'S'; } # is it a DXNet node sub is_dxnet { - my $self = shift; - return $self->{'sort'} eq 'X'; + return $_[0]->{sort} eq 'X'; } # is it a ar-cluster node sub is_arcluster { - my $self = shift; - return $self->{'sort'} eq 'R'; + return $_[0]->{sort} eq 'R'; +} + +sub is_rbn +{ + return $_[0]->{sort} eq 'N'; +} + +sub is_dslink +{ + return $_[0]->{sort} eq 'L'; } # for perl 5.004's benefit sub sort { my $self = shift; - return @_ ? $self->{'sort'} = shift : $self->{'sort'} ; + return @_ ? $self->{sort} = shift : $self->{sort} ; } # find out whether we are prepared to believe this callsign on this interface @@ -502,7 +508,7 @@ sub disconnect my $self = shift; my $user = $self->{user}; - $user->close() if defined $user; + $user->close($self->{startt}, $self->{hostname}) if defined $user; $self->{conn}->disconnect if $self->{conn}; $self->del(); } @@ -589,7 +595,7 @@ sub decode_input { my $dxchan = shift; my $data = shift; - my ($sort, $call, $line) = $data =~ /^([A-Z])([A-Z0-9\-]{3,9})\|(.*)$/; + my ($sort, $call, $line) = $data =~ /^([A-Z])(#?[A-Z0-9\/\-]{3,25})\|(.*)$/; my $chcall = (ref $dxchan) ? $dxchan->call : "UN.KNOWN"; @@ -681,7 +687,7 @@ sub broadcast_list if ($sort eq 'dx') { next unless $dxchan->{dx}; - ($filter) = $dxchan->{spotsfilter}->it(@{$fref}) if ref $fref; + ($filter) = $dxchan->{spotsfilter}->it($fref) if $dxchan->{spotsfilter} && ref $fref; next unless $filter; } next if $sort eq 'ann' && !$dxchan->{ann} && $s !~ /^To\s+LOCAL\s+de\s+(?:$main::myalias|$main::mycall)/i; @@ -699,42 +705,48 @@ sub broadcast_list } } -sub process +sub process_one { - foreach my $dxchan (get_all()) { - next if $dxchan->{disconnecting}; + my $self = shift; + + while (my $data = shift @{$self->{inqueue}}) { + my ($sort, $call, $line) = $self->decode_input($data); + next unless defined $sort; - while (my $data = shift @{$dxchan->{inqueue}}) { - my ($sort, $call, $line) = $dxchan->decode_input($data); - next unless defined $sort; - - # do the really sexy console interface bit! (Who is going to do the TK interface then?) - dbg("<- $sort $call $line") if $sort ne 'D' && isdbg('chan'); - - # handle A records - my $user = $dxchan->user; - if ($sort eq 'A' || $sort eq 'O') { - $dxchan->start($line, $sort); - } elsif ($sort eq 'I') { - die "\$user not defined for $call" if !defined $user; + # do the really sexy console interface bit! (Who is going to do the TK interface then?) + dbg("<- $sort $call $line") if $sort ne 'D' && isdbg('chan'); + + # handle A records + my $user = $self->user; + if ($sort eq 'I') { + die "\$user not defined for $call" unless defined $user; - # normal input - $dxchan->normal($line); - } elsif ($sort eq 'Z') { - $dxchan->disconnect; - } elsif ($sort eq 'D') { - ; # ignored (an echo) - } elsif ($sort eq 'C') { - $dxchan->width($line); # change number of columns - } elsif ($sort eq 'G') { - $dxchan->enhanced($line); - } else { - print STDERR atime, " Unknown command letter ($sort) received from $call\n"; - } + # normal input + $self->normal($line); + } elsif ($sort eq 'G') { + $self->enhanced($line); + } elsif ($sort eq 'A' || $sort eq 'O' || $sort eq 'W') { + $self->start($line, $sort); + } elsif ($sort eq 'C') { + $self->width($line); # change number of columns + } elsif ($sort eq 'Z') { + $self->disconnect; + } elsif ($sort eq 'D') { + ; # ignored (an echo) + } else { + dbg atime . " DXChannel::process_one: Unknown command letter ($sort) received from $call\n"; } } } +sub process +{ + foreach my $dxchan (values %channels) { + next if $dxchan->{disconnecting}; + $dxchan->process_one; + } +} + sub handle_xml { my $self = shift; @@ -748,12 +760,22 @@ sub handle_xml return $r; } -sub registered +sub error_handler +{ + my $self = shift; + my $error = shift || ''; + dbg("$self->{call} ERROR '$error', closing") if isdbg('chan'); + $self->{conn}->set_error(undef) if exists $self->{conn}; + $self->disconnect(1); +} + + +sub isregistered { my $self = shift; # the sysop is registered! - return 1 if $self->call eq $main::myalias || $self->call eq $main::mycall; + return 1 if $self->{call} eq $main::myalias || $self->{call} eq $main::mycall; if ($main::reqreg) { return $self->{registered}; diff --git a/perl/DXCommandmode.pm b/perl/DXCommandmode.pm index 6023320d..5ea58ea1 100644 --- a/perl/DXCommandmode.pm +++ b/perl/DXCommandmode.pm @@ -13,6 +13,8 @@ package DXCommandmode; @ISA = qw(DXChannel); +use 5.10.1; + use POSIX qw(:math_h); use DXUtil; use DXChannel; @@ -40,7 +42,7 @@ use AsyncMsg; use strict; use vars qw(%Cache %cmd_cache $errstr %aliases $scriptbase %nothereslug - $maxbadcount $msgpolltime $default_pagelth $cmdimportdir); + $maxbadcount $msgpolltime $default_pagelth $cmdimportdir $users $maxusers); %Cache = (); # cache of dynamically loaded routine's mod times %cmd_cache = (); # cache of short names @@ -51,7 +53,8 @@ $maxbadcount = 3; # no of bad words allowed before disconnection $msgpolltime = 3600; # the time between polls for new messages $cmdimportdir = "$main::root/cmd_import"; # the base directory for importing command scripts # this does not exist as default, you need to create it manually -# +$users = 0; # no of users on this node currently +$maxusers = 0; # max no users on this node for this run # # obtain a new connection this is derived from dxchannel @@ -65,7 +68,7 @@ sub new my $pkg = shift; my $call = shift; # my @rout = $main::routeroot->add_user($call, Route::here(1)); - DXProt::_add_thingy($main::routeroot, [$call, 0, 0, 1, undef, undef, $self->{conn}->peerhost], ); + DXProt::_add_thingy($main::routeroot, [$call, 0, 0, 1, undef, undef, $self->hostname], ); # ALWAYS output the user my $ref = Route::User::get($call); @@ -92,7 +95,7 @@ sub start my $host = $self->{conn}->peerhost; $host ||= "AGW Port #$self->{conn}->{agwport}" if exists $self->{conn}->{agwport}; $host ||= "unknown"; - LogDbg('DXCommand', "$call connected from $host"); + $self->{hostname} = $host; $self->{name} = $name ? $name : $call; $self->send($self->msg('l2',$self->{name})); @@ -102,10 +105,22 @@ sub start my $pagelth = $user->pagelth; $pagelth = $default_pagelth unless defined $pagelth; $self->{pagelth} = $pagelth; - ($self->{width}) = $line =~ /width=(\d+)/; $line =~ s/\s*width=\d+\s*//; + ($self->{width}) = $line =~ /\s*width=(\d+)/; $line =~ s/\s*width=\d+//; + $self->{enhanced} = $line =~ /\s+enhanced/; $line =~ s/\s*enhanced//; + if ($line =~ /host=/) { + my ($h) = $line =~ /host=(\d+\.\d+\.\d+\.\d+)/; + $line =~ s/\s*host=\d+\.\d+\.\d+\.\d+// if $h; + unless ($h) { + ($h) = $line =~ /host=([\da..fA..F:]+)/; + $line =~ s/\s*host=[\da..fA..F:]+// if $h; + } + $self->{hostname} = $h if $h; + } $self->{width} = 80 unless $self->{width} && $self->{width} > 80; $self->{consort} = $line; # save the connection type - + + LogDbg('DXCommand', "$call connected from $self->{hostname} cols $self->{width}" . ($self->{enhanced}?" enhanced":'')); + # set some necessary flags on the user if they are connecting $self->{beep} = $user->wantbeep; $self->{ann} = $user->wantann; @@ -118,24 +133,30 @@ sub start $self->{ann_talk} = $user->wantann_talk; $self->{here} = 1; $self->{prompt} = $user->prompt if $user->prompt; + $self->{lastmsgpoll} = 0; # sort out new dx spot stuff $user->wantdxcq(0) unless defined $user->{wantdxcq}; $user->wantdxitu(0) unless defined $user->{wantdxitu}; $user->wantusstate(0) unless defined $user->{wantusstate}; - # sort out registration (who wanted 2???) Note registration *could* be used even when reqreg == 0 + # sort out registration if ($main::reqreg == 2) { $self->{registered} = !$user->registered; } else { $self->{registered} = $user->registered; - } + } + + # establish slug queue, if required + $self->{sluggedpcs} = []; + $self->{isslugged} = $DXProt::pc92_slug_changes + $DXProt::last_pc92_slug + 5 if $DXProt::pc92_slug_changes; + $self->{isslugged} = 0 if $self->{priv} || $user->registered || ($user->homenode && $user->homenode eq $main::mycall); # send the relevant MOTD $self->send_motd; # sort out privilege reduction - $self->{priv} = 0 if $line =~ /^(ax|te)/ && !$self->conn->{usedpasswd}; + $self->{priv} = 0 unless $self->{hostname} eq '127.0.0.1' || $self->{hostname} eq '::1' || $self->conn->{usedpasswd}; # get the filters my $nossid = $call; @@ -187,8 +208,7 @@ sub start $script->run($self) if $script; # send cluster info - my $info = Route::cluster(); - $self->send("Cluster:$info"); + $self->send($self->run_cmd("show/cluster")); # send prompts for qth, name and things $self->send($self->msg('namee1')) if !$user->name; @@ -468,7 +488,7 @@ sub send_ans } # -# this is the thing that runs the command, it is done like this for the +# this is the thing that preps for running the command, it is done like this for the # benefit of remote command execution # @@ -490,7 +510,7 @@ sub run_cmd # check cmd if ($cmd =~ m|^/| || $cmd =~ m|[^-?\w/]|) { - LogDbg('DXCommand', "cmd: invalid characters in '$cmd'"); + LogDbg('DXCommand', "cmd: $self->{call} - invalid characters in '$cmd'"); return $self->_error_out('e1'); } @@ -556,9 +576,10 @@ sub process my $t = time; my @dxchan = DXChannel::get_all(); my $dxchan; - + + $users = 0; foreach $dxchan (@dxchan) { - next if $dxchan->sort ne 'U'; + next unless $dxchan->is_user; # send a outstanding message prompt if required if ($t >= $dxchan->lastmsgpoll + $msgpolltime) { @@ -571,11 +592,19 @@ sub process $dxchan->prompt() if $dxchan->{state} =~ /^prompt/o; $dxchan->t($t); } - } + ++$users; + $maxusers = $users if $users > $maxusers; + + if ($dxchan->{isslugged} && $main::systime > $dxchan->{isslugged}) { + foreach my $ref (@{$dxchan->{sluggedpcs}}) { + if ($ref->[0] == 61) { + Spot::add(@{$ref->[2]}); + DXProt::send_dx_spot($dxchan, $ref->[1], @{$ref->[2]}); + } + } - while (my ($k, $v) = each %nothereslug) { - if ($main::systime >= $v + 300) { - delete $nothereslug{$k}; + $dxchan->{isslugged} = 0; + $dxchan->{sluggedpcs} = []; } } @@ -600,7 +629,7 @@ sub disconnect # @rout = $main::routeroot->del_user($uref); @rout = DXProt::_del_thingy($main::routeroot, [$call, 0]); - dbg("B/C PC17 on $main::mycall for: $call") if isdbg('route'); + # dbg("B/C PC17 on $main::mycall for: $call") if isdbg('route'); # issue a pc17 to everybody interested $main::me->route_pc17($main::mycall, undef, $main::routeroot, $uref); @@ -652,7 +681,7 @@ sub broadcast my $s = shift; # the line to be rebroadcast foreach my $dxchan (DXChannel::get_all()) { - next unless $dxchan->{sort} eq 'U'; # only interested in user channels + next unless $dxchan->is_user; # only interested in user channels next if grep $dxchan == $_, @_; $dxchan->send($s); # send it } @@ -661,7 +690,7 @@ sub broadcast # gimme all the users sub get_all { - return grep {$_->{sort} eq 'U'} DXChannel::get_all(); + goto &DXChannel::get_all_users; } # run a script for this user @@ -791,7 +820,7 @@ sub find_cmd_name { #we have compiled this subroutine already, #it has not been updated on disk, nothing left to do #print STDERR "already compiled $package->handler\n"; - ; + dbg("find_cmd_name: $package cached") if isdbg('command'); } else { my $sub = readfilestr($filename); @@ -801,7 +830,7 @@ sub find_cmd_name { }; #wrap the code into a subroutine inside our unique package - my $eval = qq(package DXCommandmode::$package; use POSIX qw{:math_h}; use DXLog; use DXDebug; use DXUser; use DXUtil; our \@ISA = qw{DXCommandmode}; ); + my $eval = qq(package DXCommandmode::$package; use 5.10.1; use POSIX qw{:math_h}; use DXLog; use DXDebug; use DXUser; use DXUtil; our \@ISA = qw{DXCommandmode}; ); if ($sub =~ m|\s*sub\s+handle\n|) { @@ -921,7 +950,7 @@ sub announce $buf = dd(['ann', $to, $target, $text, @_]) } else { $buf = "$to$target de $_[0]: $text"; - $buf =~ s/\%5E/^/g; + #$buf =~ s/\%5E/^/g; $buf .= "\a\a" if $self->{beep}; } $self->local_send($target eq 'WX' ? 'W' : 'N', $buf); @@ -946,7 +975,7 @@ sub chat $buf = dd(['chat', $to, $target, $text, @_]) } else { $buf = "$target de $_[0]: $text"; - $buf =~ s/\%5E/^/g; + #$buf =~ s/\%5E/^/g; $buf .= "\a\a" if $self->{beep}; } $self->local_send('C', $buf); @@ -957,15 +986,15 @@ sub format_dx_spot my $self = shift; my $t = ztime($_[2]); - my $loc = ''; my ($slot1, $slot2) = ('', ''); my $clth = 30 + $self->{width} - 80; # allow comment to grow according the screen width - my $comment = substr (($_[3] || ''), 0, $clth); - $comment =~ s/\t/ /g; + my $c = $_[3]; + $c =~ s/\t/ /g; + my $comment = substr (($c || ''), 0, $clth); $comment .= ' ' x ($clth - (length($comment))); - - if (!$slot1 && $self->{user}->wantgrid) { + + if (!$slot1 && $self->{user}->wantgrid) { my $ref = DXUser::get_current($_[1]); if ($ref && $ref->qra) { $slot1 = ' ' . substr($ref->qra, 0, 4); @@ -1005,6 +1034,7 @@ sub format_dx_spot return sprintf "DX de %-8.8s%10.1f %-12.12s %-s $t$slot2", "$_[4]:", $_[0], $_[1], $comment; } + # send a dx spot sub dx_spot { @@ -1046,7 +1076,7 @@ sub dx_spot } else { $buf = $self->format_dx_spot(@_); $buf .= "\a\a" if $self->{beep}; - $buf =~ s/\%5E/^/g; + #$buf =~ s/\%5E/^/g; } $self->local_send('X', $buf); @@ -1106,7 +1136,7 @@ sub broadcast_debug { my $s = shift; # the line to be rebroadcast - foreach my $dxchan (DXChannel::get_all) { + foreach my $dxchan (DXChannel::get_all_users) { next unless $dxchan->{enhanced} && $dxchan->{senddbg}; if ($dxchan->{gtk}) { $dxchan->send_later('L', dd(['db', $s])); @@ -1182,6 +1212,9 @@ sub import_cmd my @names = readdir(DIR); closedir(DIR); my $name; + + return unless @names; + foreach $name (@names) { next if $name =~ /^\./; @@ -1246,7 +1279,7 @@ sub send_motd my $self = shift; my $motd; - unless ($self->registered) { + unless ($self->isregistered) { $motd = "${main::motd}_nor_$self->{lang}"; $motd = "${main::motd}_nor" unless -e $motd; } @@ -1262,6 +1295,10 @@ sub send_motd $self->send_file($motd) if -e $motd; } +sub user_count +{ + return ($users, $maxusers); +} 1; __END__ diff --git a/perl/DXProt.pm b/perl/DXProt.pm index fae6dde0..b6c0b759 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -248,6 +248,7 @@ sub init $main::me->{version} = $main::version; $main::me->{build} = $main::build; $main::me->{do_pc9x} = 1; + $main::me->{hostname} = $main::clusteraddr; $main::me->update_pc92_next($pc92_short_update_period); $main::me->update_pc92_keepalive; } @@ -288,7 +289,9 @@ sub start # log it my $host = $self->{conn}->peerhost; $host ||= "AGW Port #$self->{conn}->{agwport}" if exists $self->{conn}->{agwport}; + $host ||= $host if is_ipaddr($host); $host ||= "unknown"; + $self->{hostname} = $host; Log('DXProt', "$call connected from $host"); diff --git a/perl/Messages b/perl/Messages index 565ec38f..2554d270 100644 --- a/perl/Messages +++ b/perl/Messages @@ -34,6 +34,7 @@ package DXM; chatinst => 'Entering Chatmode on $_[0], /EX to end, / to run a command', chatprompt => 'Chat ($_[0])>', chattoomany => 'Not allowed, already in $_[1], use /chat $_[0]', + cluster => 'Nodes: $_[0]/$_[1] Users [Loc/Clr]: $_[2]/$_[3] Max: $_[4]/$_[5] - Uptime: $_[6]', conother => 'Sorry $_[0] you are connected to me on another port', concluster => 'Sorry $_[0] you are already connected elsewhere on the cluster (on $_[1])', contomany => 'Sorry $_[0] but you are already connected to $_[1] other nodes (on $_[2])', @@ -67,6 +68,7 @@ package DXM; dx1 => 'Frequency $_[0] not in band (see show/band); usage: DX [BY call] freq call comments', dx2 => 'Need a callsign; usage: DX [BY call] freq call comments', dx3 => 'The callsign or frequency is invalid', + dx4 => 'The ip address ($_[0]) is invalid', dxcqs => 'DX CQ Zones enabled for $_[0]', dxcqu => 'DX CQ Zones disabled for $_[0]', dxitus => 'DX ITU Zones enabled for $_[0]', @@ -91,8 +93,8 @@ package DXM; e16 => 'File \"$_[0]\" exists', e17 => 'Please don\'t use the words: @_ on here', e18 => 'Cannot connect to $_[0] ($!)', - e19 => 'Invalid character in line', - e20 => 'token $_[0] not recognised', + e19 => 'Invalid character(s) in line $_[0]', + e20 => qq{token '$_[0]' not recognised}, e21 => '$_[0] is not numeric', e22 => '$_[0] is not a callsign', e23 => '$_[0] is not a range (eg 0/30000)', @@ -111,6 +113,7 @@ package DXM; e36 => 'You can only do this in normal user prompt state', e37 => 'Need at least a callsign', e38 => 'This is not a valid regex', + e39 => 'Sorry $_[0] is not a valid argument', echoon => 'Echoing enabled', echooff => 'Echoing disabled', @@ -127,6 +130,7 @@ package DXM; filter4 => '$_[0]$_[1] Filter $_[2] deleted for $_[3]', filter5 => 'need some filter commands...', filter6 => '$_[0]$_[1] Filter for $[2] not found', + filter7 => '$_[0] parse error $_[1] on $_[2]', grayline1 => ' Beg of End of', grayline2 => 'Location dd/mm/yyyy Dawn Rise Set Dusk', grids => 'DX Grid enabled for $_[0]', @@ -160,7 +164,7 @@ package DXM; isow => '$_[0] is isolated; unset/isolate $_[0] first', join => 'joining group $_[0]', l1 => 'Sorry $_[0], you are already logged on on another channel', - l2 => 'Hello $_[0], this is $main::mycall in $main::myqth\nrunning DXSpider V$main::version build $main::build on $^O', + l2 => 'Hello $_[0], this is $main::mycall in $main::myqth\nrunning DXSpider V$main::version build $main::build', lang => 'Language is now English', lange1 => 'set/language where is one of ($_[0])', lange2 => 'failed to set language on $_[0]', @@ -206,8 +210,9 @@ package DXM; m17 => 'Sorry, cannot send messages in $_[0] mode', m18 => 'Sorry, message $_[0] is currently set to KEEP', m19 => 'Startup Script for $_[0] saved, $_[1] lines', - m20 => 'Empty Startup Script for $_[0] deleted', + m20 => 'Startup Script for $_[0] deleted', m21 => '$_[0] Working...', + m22 => 'Startup Script for $_[0] not found/error $!', maxconnect => 'Max connections on $_[0] set to $_[1]', msg1 => 'Bulletin Messages Queued', msg2 => 'Private Messages Queued', @@ -232,6 +237,8 @@ package DXM; noderc => '$_[0] created as AR-Cluster style Node', nodes => '$_[0] set as DXSpider style Node', nodesc => '$_[0] created as DXSpider style Node', + noden => '$_[0] set as RBN Feed ', + nodenc => '$_[0] created as RBN Feed', nodex => '$_[0] set as DXNET style Node', nodexc => '$_[0] created as DXNET style Node', nodeu => '$_[0] set back as a User', @@ -242,7 +249,7 @@ package DXM; ok => 'Operation successful', outconn => 'Outstanding connect to $_[0]', page => 'Press Enter to continue, A to abort ($_[0] lines) >', - pagelth => 'Page Length is now $_[0]', + pagelth => 'Page Length is now $_[0] lines', pagewidth => 'Page width is now $_[0] columns', passerr => 'Please use: SET/PASS ', passphrase => 'Passphrase set or changed for $_[0]', @@ -273,6 +280,7 @@ package DXM; qrashe1 => 'Please enter a QRA locator, eg sh/qra JO02LQ or sh/qra JO02LQ IO93NS', qrae2 => 'Don\'t recognise \"$_[0]\" as a QRA locator (eg JO02LQ)', qra => 'Your QRA Locator is now \"$_[0]\"', + rbnusers => qq{RBN User List}, qsl1 => 'Call Manager Times Last Time Seen De', rcmdo => 'RCMD \"$_[0]\" sent to $_[1]', read1 => 'Sorry, no new messages for you', @@ -298,6 +306,7 @@ package DXM; showconf => 'Node Callsigns', shu => '\"SHU\" is not enough! you need to type at least \"SHUT\" to shutdown the node', shutting => '$main::mycall shutting down...', + skims => 'RBN/Skimming set to $_[1] for $_[0]', sloc => 'Cluster lat $_[0] long $_[1], DON\'T FORGET TO CHANGE YOUR DXVars.pm', snode1 => 'Node Call Sort Version', snode2 => '$_[0] $_[1] $_[2]', @@ -339,6 +348,8 @@ package DXM; usernf => '*** User record for $_[0] not found ***', usstates => 'US State display enabled for $_[0]', usstateu => 'US State display disabled for $_[0]', + wante => 'Want $_[0] enabled for $_[1]', + wantd => 'Want $_[0] disabled for $_[1]', wcy1 => '$_[0] is missing or out of range', wcy2 => 'Duplicate WCY', wcy3 => 'Date Hour SFI A K Exp.K R SA GMF Aurora Logger', @@ -352,7 +363,7 @@ package DXM; wpc9xu => 'PC9X for $_[0] disabled', wwv1 => '$_[0] is missing or out of range', wwv2 => 'Duplicate WWV', - wwv3 => 'Date Hour SFI A K Forecast Logger', + wwv3 => 'Date Hour SFI A K Forecast Logger', wwvs => 'WWV enabled for $_[0]', wwvu => 'WWV disabled $_[0]', wxs => 'WX enabled for $_[0]', @@ -524,7 +535,7 @@ package DXM; e16 => 'Le fichier \"$_[0]\" existe déjà', e17 => 'Prière de ne pas utiliser les mots : @_ ici !', e18 => 'Connexion impossible avec $_[0] ($!)', - e19 => 'Caractère non valide dans la ligne', + e19 => 'Caractère non valide dans la ligne $_[0]', e20 => 'Symbole $_[0] non reconnu', e21 => '$_[0] n\'est pas une valeur numérique', e22 => '$_[0] n\'est pas un indicatif', @@ -846,7 +857,7 @@ package DXM; e16 => 'El fichero \"$_[0]\" ya existe', e17 => 'Por favor no uses la palabra: @_ aquí', e18 => 'No se puede conectar con $_[0] ($!)', - e19 => 'Carácter no válido en la línea', + e19 => 'Carácter no válido en la línea $_[0]', e20 => 'Símbolo $_[0] no reconocido', e21 => '$_[0] no es numérico', e22 => '$_[0] no es un indicativo', @@ -1171,7 +1182,7 @@ package DXM; e16 => 'Datei \"$_[0]\" existiert', e17 => 'Bitte gebrauche dieses Wort: @_ nicht hier', e18 => 'Kann nicht verbinden mit $_[0] ($!)', - e19 => 'Ungueltiger Character in der Zeile', + e19 => 'Ungueltiger Character in der Zeile $_[0]', e20 => 'Kuerzel $_[0] nicht erkannt', e21 => '$_[0] nicht numerisch', e22 => '$_[0] kein Rufzeichen', @@ -1445,7 +1456,7 @@ package DXM; e16 => 'Il file \"$_[0]\" esiste', e17 => 'Non usare le parole: @_ qui', e18 => 'Impossibile connettere $_[0] ($!)', - e19 => 'Carattere non valido nella linea', + e19 => 'Carattere non valido nella linea $_[0]', e20 => 'separatore $_[0] non riconosciuto', e21 => '$_[0] non e\' numerico', e22 => '$_[0] non e\' un nominativo', @@ -1718,7 +1729,7 @@ package DXM; e16 => 'Soubor \"$_[0]\" uz existuje', e17 => 'Prosim nepouzivej zde toto slovo: @_', e18 => 'Nemohu se pripojit na $_[0] ($!)', - e19 => 'neplatny znak v radku', + e19 => 'neplatny znak v radku $_[0]', e20 => 'retezec $_0] nebyl rozpoznan', e21 => '$_[0] neni cislo', e22 => '$_[0] neni znacka', @@ -2010,7 +2021,7 @@ package DXM; e16 => 'O ficheiro \"$_[0]\" existe', e17 => 'Por favor no use as palavras: @_ aqui', e18 => 'No posso ligar a $_[0] ($!)', - e19 => 'Caracter invlido na linha', + e19 => 'Caracter invlido na linha $_[0]', e20 => 'sinal $_[0] no reconhecido', e21 => '$_[0] no numrico', e22 => '$_[0] no um indicativo', diff --git a/perl/Route.pm b/perl/Route.pm index c43fd34d..304b9c68 100644 --- a/perl/Route.pm +++ b/perl/Route.pm @@ -25,6 +25,7 @@ use strict; use vars qw(%list %valid $filterdef $maxlevel); %valid = ( + parent => '0,Parent Calls,parray', call => "0,Callsign", flags => "0,Flags,phex", dxcc => '0,Country Code', @@ -32,6 +33,7 @@ use vars qw(%list %valid $filterdef $maxlevel); cq => '0,CQ Zone', state => '0,State', city => '0,City', + ip => '0,IP Address', ); $filterdef = bless ([ @@ -222,12 +224,14 @@ sub config my $c; if ($uref) { $c = $uref->user_call; - } else { + } + else { $c = "$ucall?"; } if ((length $line) + (length $c) + 1 < $width) { $line .= $c . ' '; - } else { + } + else { $line =~ s/\s+$//; push @out, $line; $line = ' ' x ($level*2) . "$pcall->$c "; @@ -238,7 +242,8 @@ sub config $line =~ s/->$//g; $line =~ s/\s+$//; push @out, $line if length $line; - } else { + } + else { # recursion detector if ((DXChannel::get($call) && $level > 1) || $seen->{$call} || $level > $maxlevel) { return @out; @@ -270,11 +275,14 @@ sub cluster { my $nodes = Route::Node::count(); my $tot = Route::User::count(); - my $users = scalar DXCommandmode::get_all(); + my ($users, $maxlocalusers) = DXCommandmode::user_count(); # the user count is wrong because of skimmers my $maxusers = Route::User::max(); my $uptime = main::uptime(); + my $localnodes = $DXChannel::count - $users; # this is now wrong because of skimmers + + return ($nodes, $tot, $users, $maxlocalusers, $maxusers, $uptime, $localnodes); + - return " $nodes nodes, $users local / $tot total users Max users $maxusers Uptime $uptime"; } # diff --git a/perl/Route/Node.pm b/perl/Route/Node.pm index 89e84d40..76d98757 100644 --- a/perl/Route/Node.pm +++ b/perl/Route/Node.pm @@ -19,7 +19,6 @@ use vars qw(%list %valid @ISA $max $filterdef $obscount); @ISA = qw(Route); %valid = ( - parent => '0,Parent Calls,parray', nodes => '0,Nodes,parray', users => '0,Users,parray', usercount => '0,User Count', @@ -29,11 +28,10 @@ use vars qw(%list %valid @ISA $max $filterdef $obscount); lastmsg => '0,Last Route Msg,atime', lastid => '0,Last Route MsgID', do_pc9x => '0,Uses pc9x,yesno', - via_pc92 => '0,Came in via pc92,yesno', + via_pc92 => '0,In via pc92?,yesno', obscount => '0,Obscount', last_PC92C => '9,Last PC92C', - PC92C_dxchan => '9,Channel of PC92C,phash', - ip => '0,IP Address', + PC92C_dxchan => '9,PC92C hops,phash', ); $filterdef = $Route::filterdef; @@ -205,6 +203,14 @@ sub del_user return @out; } +# is a user on this node +sub is_user +{ + my $self = shift; + my $call = shift; + return scalar grep {$_ eq $call} @{$self->{users}}; +} + sub usercount { my $self = shift; @@ -272,6 +278,7 @@ sub calc_config_changes return (\@dnodes, \@dusers, \@nnodes, \@nusers); } + sub new { my $pkg = shift; diff --git a/perl/Route/User.pm b/perl/Route/User.pm index 0cd17029..8c1c824d 100644 --- a/perl/Route/User.pm +++ b/perl/Route/User.pm @@ -17,11 +17,6 @@ use strict; use vars qw(%list %valid @ISA $max $filterdef); @ISA = qw(Route); -%valid = ( - parent => '0,Parent Calls,parray', - ip => '0,IP Address', -); - $filterdef = $Route::filterdef; %list = (); $max = 0; @@ -99,8 +94,6 @@ sub delparent return $self->_dellist('parent', @_); } - - # # generic AUTOLOAD for accessors # diff --git a/perl/cluster.pl b/perl/cluster.pl index c2cb8e08..f1eade41 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -18,8 +18,6 @@ package main; use vars qw($data $system $cmd $localcmd $userfn $clusteraddr $clusterport $yes $no $user_interval $lang); $lang = 'en'; # default language -$clusteraddr = '127.0.0.1'; # cluster tcp host address - used for things like console.pl -$clusterport = 27754; # cluster tcp port $yes = 'Yes'; # visual representation of yes $no = 'No'; # ditto for no $user_interval = 11*60; # the interval between unsolicited prompts if no traffic @@ -141,6 +139,9 @@ use vars qw(@inqueue $systime $starttime $lockfn @outstanding_connects $can_encode $maxconnect_user $maxconnect_node ); + +$clusteraddr //= '127.0.0.1'; # cluster tcp host address - used for things like console.pl +$clusterport //= 27754; # cluster tcp port @inqueue = (); # the main input queue, an array of hashes $systime = 0; # the time now (in seconds) $starttime = 0; # the starting time of the cluster diff --git a/perl/console.pl b/perl/console.pl index 3fbc46fe..8de22e82 100755 --- a/perl/console.pl +++ b/perl/console.pl @@ -1,4 +1,4 @@ -#!/usr/bin/perl -w +#!/usr/bin/env perl # # this is the operators console. # @@ -13,8 +13,8 @@ # # -require 5.004; -package main; +require 5.10.1; +use warnings; use vars qw($data $clusteraddr $clusterport); @@ -42,7 +42,7 @@ use DXDebug; use IO::File; use Time::HiRes qw(gettimeofday tv_interval); use Curses 1.06; -use Text::Wrap; +use Text::Wrap qw(wrap); use Console; @@ -50,27 +50,24 @@ use Console; # initialisation # +$clusteraddr //= '127.0.0.1'; +$clusterport //= 27754; + $call = ""; # the callsign being used $node = ""; # the node callsign being used - $conn = 0; # the connection object for the cluster $lasttime = time; # lasttime something happened on the interface $connsort = "local"; @kh = (); @sh = (); -$khistpos = 0; +$kpos = 0; $spos = $pos = $lth = 0; $inbuf = ""; -@time = (); +$inscroll = 0; -#$SIG{WINCH} = sub {@time = gettimeofday}; -sub mydbg -{ - local *STDOUT = undef; - dbg(@_); -} +#$SIG{WINCH} = sub {@time = gettimeofday}; # do the screen initialisation sub do_initscr @@ -99,19 +96,21 @@ sub do_initscr $top = $scr->subwin($lines-4, $cols, 0, 0); $top->intrflush(0); - $top->scrollok(1); + $top->scrollok(0); $top->idlok(1); $top->meta(1); -# $scr->addstr($lines-4, 0, '-' x $cols); + $top->leaveok(1); + $top->clrtobot(); $bot = $scr->subwin(3, $cols, $lines-3, 0); $bot->intrflush(0); $bot->scrollok(1); - $top->idlok(1); $bot->keypad(1); $bot->move(1,0); $bot->meta(1); $bot->nodelay(1); + $bot->clrtobot(); $scr->refresh(); + $pagel = $lines-4; $mycallcolor = COLOR_PAIR(1) unless $mycallcolor; @@ -128,11 +127,11 @@ sub do_resize $cols = COLS; $has_colors = has_colors(); do_initscr(); + $inscroll = 0; $spos = @sh < $pagel ? 0 : @sh - $pagel; show_screen(); $conn->send_later("C$call|$cols") if $conn; - } # cease communications @@ -168,7 +167,8 @@ sub setattr # display the top screen sub show_screen -{ if ($inscroll) { +{ + if ($inscroll) { dbg("B: s:$spos h:" . scalar @sh) if isdbg('console'); my ($i, $l); @@ -234,72 +234,12 @@ sub show_screen # $top->refresh(); } -# add a line to the end of the top screen -sub addtotop -{ - while (@_) { - my $inbuf = shift; - my $l = length $inbuf; - if ($l > $cols) { - $inbuf =~ s/\s+/ /g; - if (length $inbuf > $cols) { - $Text::Wrap::columns = $cols; - my $token; - ($token) = $inbuf =~ m!^(.* de [-\w\d/\#]+:?\s+|\w{9}\@\d\d:\d\d:\d\d )!; - $token ||= ' ' x 19; - push @sh, split /\n/, wrap('', ' ' x length($token), $inbuf); - } else { - push @sh, $inbuf; - } - } else { - push @sh, $inbuf; - } - } -# shift @sh while @sh > $maxshist; - show_screen(); -} - -# handle incoming messages -sub rec_socket -{ - my ($con, $msg, $err) = @_; - if (defined $err && $err) { - cease(1); - } - if (defined $msg) { - my ($sort, $incall, $line) = $msg =~ /^(\w)([^\|]+)\|(.*)$/; - if ($line =~ s/\x07+$//) { - beep(); - } - $line =~ s/[\r\n]+//s; - - # change my call if my node says "tonight Michael you are Jane" or something like that... - $call = $incall if $call ne $incall; - - $line =~ s/[\x00-\x06\x08\x0a-\x19\x1b-\x1f\x80-\x9f]/./g; # immutable CSI sequence + control characters - if ($sort && $sort eq 'D') { - $line = " " unless length($line); - addtotop($line); - } elsif ($sort && $sort eq 'Z') { # end, disconnect, go, away ..... - cease(0); - } - - # ****************************************************** - # ****************************************************** - # any other sorts that might happen are silently ignored. - # ****************************************************** - # ****************************************************** - } else { - cease(0); - } - $top->refresh(); - $lasttime = time; -} - sub rec_stdin { - my $r = shift;; + my $r = shift; + dbg("KEY: " . unpack("H*", $r). " '$r'") if isdbg('console'); + # my $prbuf; # $prbuf = $buf; # $prbuf =~ s/\r/\\r/; @@ -308,7 +248,7 @@ sub rec_stdin if (defined $r) { $r = '0' if !$r; - + if ($r eq KEY_ENTER || $r eq "\n" || $r eq "\r") { # save the lines @@ -331,7 +271,7 @@ sub rec_stdin } push @kh, $inbuf if length $inbuf; shift @kh if @kh > $maxkhist; - $khistpos = @kh; + $kpos = @kh; $bot->move(0,0); $bot->clrtoeol(); $bot->addstr(substr($inbuf, 0, $cols)); @@ -342,25 +282,24 @@ sub rec_stdin show_screen(); } - # add it to the monitor window - addtotop($inbuf); + addtotop(' ', $inbuf); # send it to the cluster $conn->send_later("I$call|$inbuf"); $inbuf = ""; $pos = $lth = 0; } elsif ($r eq KEY_UP || $r eq "\020") { - if ($khistpos > 0) { - --$khistpos; - $inbuf = $kh[$khistpos]; + if ($kpos > 0) { + --$kpos; + $inbuf = $kh[$kpos]; $pos = $lth = length $inbuf; } else { beep(); } } elsif ($r eq KEY_DOWN || $r eq "\016") { - if ($khistpos < @kh - 1) { - ++$khistpos; - $inbuf = $kh[$khistpos]; + if ($kpos < @kh - 1) { + ++$kpos; + $inbuf = $kh[$kpos]; $pos = $lth = length $inbuf; } else { beep(); @@ -377,6 +316,7 @@ sub rec_stdin } elsif ($r eq KEY_NPAGE || $r eq "\026") { if ($inscroll && $spos < @sh) { + dbg("NPAGE sp:$spos $sh:". scalar @sh . " pl: $pagel") if isdbg('console'); $spos += int($pagel/2); if ($spos > @sh - $pagel) { $spos = @sh - $pagel; @@ -429,12 +369,21 @@ sub rec_stdin beep(); } } elsif ($r eq KEY_RESIZE || $r eq "\0632") { - do_resize(); + doresize(); + return; + } elsif ($r eq "\x12" || $r eq "\x0c") { + dbg("REDRAW called") if isdbg('console'); + doresize(); return; + } elsif ($r eq "\013") { + $inbuf = substr($inbuf, 0, $pos); + $lth = length $inbuf; } elsif (defined $r && is_pctext($r)) { # move the top screen back to the bottom if you type something - if ($spos < @sh) { - $spos = @sh; + + if ($inscroll && $spos < @sh) { + $spos = @sh - $pagel; + $inscroll = 0; show_screen(); } @@ -450,16 +399,10 @@ sub rec_stdin } $pos++; $lth++; - } elsif ($r eq "\014" || $r eq "\022") { - touchwin(curscr, 1); - refresh(curscr); - return; - } elsif ($r eq "\013") { - $inbuf = substr($inbuf, 0, $pos); - $lth = length $inbuf; } else { beep(); } + $bot->move(1, 0); $bot->clrtobot(); $bot->addstr($inbuf); @@ -469,18 +412,87 @@ sub rec_stdin } +# add a line to the end of the top screen +sub addtotop +{ + my $sort = shift; + while (@_) { + my $inbuf = shift; + my $l = length $inbuf; + if ($l > $cols) { + $inbuf =~ s/\s+/ /g; + if (length $inbuf > $cols) { + $Text::Wrap::columns = $cols; + my $token; + ($token) = $inbuf =~ m!^(.* de [-\w\d/\#]+:?\s+|\w{9}\@\d\d:\d\d:\d\d )!; + $token ||= ' ' x 19; + push @sh, split /\n/, wrap('', ' ' x length($token), $inbuf); + } else { + push @sh, $inbuf; + } + } else { + push @sh, $inbuf; + } + } + + show_screen() unless $inscroll; +} + +# handle incoming messages +sub rec_socket +{ + my ($con, $msg, $err) = @_; + if (defined $err && $err) { + cease(1); + } + if (defined $msg) { + my ($sort, $incall, $line) = $msg =~ /^(\w)([^\|]+)\|(.*)$/; + dbg("msg: " . length($msg) . " '$msg'") if isdbg('console'); + if ($line =~ s/\x07+$//) { + beep(); + } + $line =~ s/[\r\n]+//s; + + # change my call if my node says "tonight Michael you are Jane" or something like that... + $call = $incall if $call ne $incall; + + $line =~ s/[\x00-\x06\x08\x0a-\x19\x1b-\x1f\x80-\x9f]/./g; # immutable CSI sequence + control characters + if ($sort && $sort eq 'Z') { # end, disconnect, go, away ..... + cease(0); + } else { + $line = " " unless length($line); + addtotop($sort, $line); + } + + } else { + cease(0); + } + $top->refresh(); + $lasttime = time; +} + # # deal with args # +while (@ARGV && $ARGV[0] =~ /^-/) { + my $arg = shift; + if ($arg eq '-x') { + dbginit('console'); + dbgadd('console'); + $maxshist = 200; + } +} + $call = uc shift @ARGV if @ARGV; -$call = uc $myalias if !$call; +$call = uc $myalias unless $call; $node = uc $mycall unless $node; +$call = normalise_call($call); my ($scall, $ssid) = split /-/, $call; $ssid = undef unless $ssid && $ssid =~ /^\d+$/; if ($ssid) { - $ssid = 15 if $ssid > 15; + $ssid = 99 if $ssid > 99; $call = "$scall-$ssid"; } @@ -489,7 +501,6 @@ if ($call eq $mycall) { exit(0); } -dbginit(); $conn = IntMsg->connect("$clusteraddr", $clusterport, \&rec_socket); if (! $conn) { @@ -520,7 +531,8 @@ do_resize(); $SIG{__DIE__} = \&sig_term; -$conn->send_later("A$call|$connsort width=$cols"); +$Text::Wrap::columns = $cols; +$conn->send_later("A$call|$connsort width=$cols enhanced"); $conn->send_later("I$call|set/page $maxshist"); $conn->send_later("I$call|set/nobeep"); @@ -554,4 +566,4 @@ for (;;) { $bot->refresh(); } -exit(0); +cease(0); diff --git a/perl/watchdbg b/perl/watchdbg index 84a74c8f..79a72f60 100755 --- a/perl/watchdbg +++ b/perl/watchdbg @@ -3,15 +3,18 @@ # watch the end of the current debug file (like tail -f) applying # any regexes supplied on the command line. # +# There can be more than one . a preceeded by a '!' is +# treated as NOT . Each is implcitly ANDed together. +# All are caseless. +# # examples:- # # watchdbg g1tlh # watch everything g1tlh does -# watchdbg 2 PCPROT # watch all PCPROT messages + up to 2 lines before +# watchdbg -2 PCPROT # watch all PCPROT messages + up to 2 lines before # watchdbg gb7baa gb7djk # watch the conversation between BAA and DJK # require 5.004; -package main; # search local then perl directories BEGIN { @@ -23,8 +26,6 @@ BEGIN { unshift @INC, "$root/local"; } -$data = "$root/data"; - use IO::File; use DXVars; use DXUtil; @@ -38,18 +39,28 @@ my $fh = $fp->open($today) or die $!; my $nolines = 1; $nolines = shift if $ARGV[0] =~ /^-?\d+$/; $nolines = abs $nolines if $nolines < 0; -my $exp = join '|', @ARGV; +my @patt = @ARGV; my @prev; # seek to end of file $fh->seek(0, 2); for (;;) { - my $line = <$fh>; + my $line = $fh->getline; if ($line) { - if ($exp) { + if (@patt) { push @prev, $line; shift @prev while @prev > $nolines; - if ($line =~ m{(?:$exp)}oi) { + my $flag = 0; + foreach my $p (@patt) { + if ($p =~ /^!/) { + my $r = substr $p, 1; + last if $line =~ m{$r}i; + } else { + last unless $line =~ m{$p}i; + } + ++$flag; + } + if ($flag == @patt) { printit(@prev); @prev = (); } @@ -82,10 +93,8 @@ sub printit chomp $line; $line =~ s/([\x00-\x1f\x7f-\xff])/sprintf("\\x%02X", ord($1))/eg; my ($t, $l) = split /\^/, $line, 2; - my ($sec,$min,$hour) = gmtime((defined $t) ? $t : time); - my $buf = sprintf "%02d:%02d:%02d", $hour, $min, $sec; - - print $buf, ' ', $l, "\n"; + $t = time unless defined $t; + printf "%02d:%02d:%02d %s\n", (gmtime($t))[2,1,0], $l; } } exit(0); -- 2.43.0