mirror of
git://scm.dxcluster.org/scm/spider
synced 2024-09-21 07:47:10 +00:00
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.
This commit is contained in:
Dirk Koopman
parent
0bca436851
commit
4b207544da
2
Changes
2
Changes
@ -1,3 +1,5 @@
|
||||
07Jan22=======================================================================
|
||||
1. Backport console.pl from the Mojo Branch.
|
||||
06Jan22=======================================================================
|
||||
1. Backport various Mojo branch "security" fixes.
|
||||
12Dec21=======================================================================
|
||||
|
||||
@ -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 = '*';
|
||||
|
||||
@ -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];
|
||||
|
||||
|
||||
103
cmd/dx.pl
103
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);
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
29
cmd/links.pl
29
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)
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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));
|
||||
|
||||
@ -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);
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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) ],
|
||||
);
|
||||
}
|
||||
|
||||
|
||||
|
||||
@ -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,39 +705,45 @@ sub broadcast_list
|
||||
}
|
||||
}
|
||||
|
||||
sub process_one
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
while (my $data = shift @{$self->{inqueue}}) {
|
||||
my ($sort, $call, $line) = $self->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 = $self->user;
|
||||
if ($sort eq 'I') {
|
||||
die "\$user not defined for $call" unless defined $user;
|
||||
|
||||
# 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 (get_all()) {
|
||||
foreach my $dxchan (values %channels) {
|
||||
next if $dxchan->{disconnecting};
|
||||
|
||||
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;
|
||||
|
||||
# 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";
|
||||
}
|
||||
}
|
||||
$dxchan->process_one;
|
||||
}
|
||||
}
|
||||
|
||||
@ -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};
|
||||
|
||||
@ -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;
|
||||
|
||||
while (my ($k, $v) = each %nothereslug) {
|
||||
if ($main::systime >= $v + 300) {
|
||||
delete $nothereslug{$k};
|
||||
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]});
|
||||
}
|
||||
}
|
||||
|
||||
$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__
|
||||
|
||||
@ -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");
|
||||
|
||||
|
||||
@ -34,6 +34,7 @@ package DXM;
|
||||
chatinst => 'Entering Chatmode on $_[0], /EX to end, /<cmd> 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 <lang> where <lang> 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 <password> <callsign>',
|
||||
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',
|
||||
|
||||
@ -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";
|
||||
}
|
||||
|
||||
#
|
||||
|
||||
@ -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;
|
||||
|
||||
@ -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
|
||||
#
|
||||
|
||||
@ -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
|
||||
|
||||
224
perl/console.pl
224
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,28 +50,25 @@ 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(@_);
|
||||
}
|
||||
|
||||
# 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);
|
||||
|
||||
@ -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 <regexp>. a <regexp> preceeded by a '!' is
|
||||
# treated as NOT <regexp>. Each <regexp> is implcitly ANDed together.
|
||||
# All <regexp> 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);
|
||||
|
||||
Loading…
Reference in New Issue
Block a user