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.
+07Jan22=======================================================================
+1. Backport console.pl from the Mojo Branch.
06Jan22=======================================================================
1. Backport various Mojo branch "security" fixes.
12Dec21=======================================================================
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 = '*';
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];
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)) {
# 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];
} 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;
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 :-)
}
$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);
}
}
-
-
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';
$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)
@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;
# 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;
#
# 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));
# 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);
$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;
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;
my $type = $dxchan->is_node ? "NODE" : "USER";\r
my $sort = " ";\r
if ($dxchan->is_node) {\r
- $sort = 'ANEA' if $dxchan->is_aranea;\r
$sort = "DXSP" if $dxchan->is_spider;\r
$sort = "CLX " if $dxchan->is_clx;\r
$sort = "DXNT" if $dxchan->is_dxnet;\r
$sort = "AR-C" if $dxchan->is_arcluster;\r
$sort = "AK1A" if $dxchan->is_ak1a;\r
+ } else {\r
+ $sort = "LOCL" if $dxchan->conn->isa('IntMsg');\r
+ $sort = "WEB " if $dxchan->is_web;\r
+ $sort = "EXT " if $dxchan->conn->isa('ExtMsg');\r
+ $type = "RBN " if $dxchan->is_rbn; # Yes, this is NOT a typo\r
}\r
my $name = $dxchan->user->name || " ";\r
my $ping = $dxchan->is_node && $dxchan != $main::me ? sprintf("%5.2f", $dxchan->pingave) : " ";\r
my $conn = $dxchan->conn;\r
my $ip = '';\r
if ($conn) {\r
- $ip = $conn->{peerhost} if exists $conn->{peerhost};\r
+ $ip = $dxchan->hostname;\r
$ip = "AGW Port ($conn->{agwport})" if exists $conn->{agwport};\r
}\r
push @out, sprintf "%10s $type $sort $t %-10.10s $ping $ip", $call, $name;\r
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
$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) ],
+ );
}
# 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
#
#
#
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 ',
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
$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} = [];
if (defined $msg) {
push @{$self->{inqueue}}, $msg;
}
+ $self->process_one;
}
# obtain a channel object by callsign [$obj = DXChannel::get($call)]
# 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
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();
}
{
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";
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;
}
}
-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;
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};
@ISA = qw(DXChannel);
+use 5.10.1;
+
use POSIX qw(:math_h);
use DXUtil;
use DXChannel;
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
$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
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);
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}));
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;
$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;
$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;
}
#
-# 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
#
# 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');
}
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) {
$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} = [];
}
}
# @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);
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
}
# 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
#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);
};
#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|) {
$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);
$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);
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);
return sprintf "DX de %-8.8s%10.1f %-12.12s %-s $t$slot2", "$_[4]:", $_[0], $_[1], $comment;
}
+
# send a dx spot
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);
{
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]));
my @names = readdir(DIR);
closedir(DIR);
my $name;
+
+ return unless @names;
+
foreach $name (@names) {
next if $name =~ /^\./;
my $self = shift;
my $motd;
- unless ($self->registered) {
+ unless ($self->isregistered) {
$motd = "${main::motd}_nor_$self->{lang}";
$motd = "${main::motd}_nor" unless -e $motd;
}
$self->send_file($motd) if -e $motd;
}
+sub user_count
+{
+ return ($users, $maxusers);
+}
1;
__END__
$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;
}
# 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");
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])',
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]',
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)',
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',
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]',
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]',
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',
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',
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]',
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',
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]',
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',
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]',
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',
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',
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',
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',
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',
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',
use vars qw(%list %valid $filterdef $maxlevel);
%valid = (
+ parent => '0,Parent Calls,parray',
call => "0,Callsign",
flags => "0,Flags,phex",
dxcc => '0,Country Code',
cq => '0,CQ Zone',
state => '0,State',
city => '0,City',
+ ip => '0,IP Address',
);
$filterdef = bless ([
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 ";
$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;
{
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";
}
#
@ISA = qw(Route);
%valid = (
- parent => '0,Parent Calls,parray',
nodes => '0,Nodes,parray',
users => '0,Users,parray',
usercount => '0,User Count',
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;
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;
return (\@dnodes, \@dusers, \@nnodes, \@nusers);
}
+
sub new
{
my $pkg = shift;
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;
return $self->_dellist('parent', @_);
}
-
-
#
# generic AUTOLOAD for accessors
#
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
$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
-#!/usr/bin/perl -w
+#!/usr/bin/env perl
#
# this is the operators console.
#
#
#
-require 5.004;
-package main;
+require 5.10.1;
+use warnings;
use vars qw($data $clusteraddr $clusterport);
use IO::File;
use Time::HiRes qw(gettimeofday tv_interval);
use Curses 1.06;
-use Text::Wrap;
+use Text::Wrap qw(wrap);
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
$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;
$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
# display the top screen
sub show_screen
-{ if ($inscroll) {
+{
+ if ($inscroll) {
dbg("B: s:$spos h:" . scalar @sh) if isdbg('console');
my ($i, $l);
# $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/;
if (defined $r) {
$r = '0' if !$r;
-
+
if ($r eq KEY_ENTER || $r eq "\n" || $r eq "\r") {
# save the lines
}
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));
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();
} 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;
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();
}
}
$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);
}
+# 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";
}
exit(0);
}
-dbginit();
$conn = IntMsg->connect("$clusteraddr", $clusterport, \&rec_socket);
if (! $conn) {
$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");
$bot->refresh();
}
-exit(0);
+cease(0);
# 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 {
unshift @INC, "$root/local";
}
-$data = "$root/data";
-
use IO::File;
use DXVars;
use DXUtil;
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 = ();
}
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);
projects / spider.git / commitdiff