From 3c56356646c5e91997c3f3741730fbc6aa178d93 Mon Sep 17 00:00:00 2001 From: Dirk Koopman Date: Sat, 11 Dec 2021 19:01:11 +0000 Subject: [PATCH] part backport from mojo --- cmd/dx.pl | 76 +++++--- perl/DXChannel.pm | 135 +++++++------ perl/DXMsg.pm | 10 +- perl/DXProt.pm | 109 +++++++---- perl/DXProtHandle.pm | 443 ++++++++++++++++++++++++++++--------------- perl/DXProtout.pm | 14 +- perl/DXUtil.pm | 158 ++++++++++++--- perl/Version.pm | 4 +- perl/cluster.pl | 2 +- perl/issue.pl | 2 +- 10 files changed, 634 insertions(+), 319 deletions(-) diff --git a/cmd/dx.pl b/cmd/dx.pl index 18687a68..27099f24 100644 --- a/cmd/dx.pl +++ b/cmd/dx.pl @@ -16,8 +16,12 @@ 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 @bad; if (@bad = BadWords::check($line)) { @@ -53,22 +57,37 @@ if (is_freq($f[1]) && $f[0] =~ m{^[\w\d]+(?:/[\w\d]+){0,2}$}) { return (1, $self->msg('dx3')); } + +my $ipaddr; +my $addr = $self->hostname; + +if ($self->conn && $self->conn->peerhost) { +# $ipaddr = $addr unless !is_ipaddr($addr) || $addr =~ /^127\./ || $addr =~ /^::[0-9a-f]+$/; + $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)"); +if ($DXProt::badspotter->in($spotternoid)) { + LogDbg('DXCommand', "badspotter $spotternoid as $spotter ($oline) from $addr"); $localonly++; } -if ($callnoid ne $spotternoid && $DXProt::badspotter->in($spotternoid)) { - LogDbg('DXCommand', "$self->{call} badspotter with $spotternoid ($line)"); - $localonly++; + +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++; } # make line the rest of the line @@ -120,20 +139,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); 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 +154,26 @@ if ($freq =~ /^69/ || $localonly) { } $self->dx_spot(undef, undef, @spot); + return (1); } else { - if (@spot) { - # store it - 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); - } + my $spot; + + if ($ipaddr) { + $spot = DXProt::pc61($spotter, $freq, $spotted, $line, $ipaddr); + } + #else { + # $spot = DXProt::pc11($spotter, $freq, $spotted, $line); + #} + + $self->dx_spot(undef, undef, @spot); + if ($self->isslugged) { + push @{$self->{sluggedpcs}}, [61, $spot, \@spot]; + } else { + # store in spots database + Spot::add(@spot); + DXProt::send_dx_spot($self, $spot, @spot); } } diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index f2a1638c..a0bc6ab9 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -19,7 +19,7 @@ # firstly and OO about ninthly (if you don't like the design and you can't # improve it with better OO and thus make it smaller and more efficient, then tough). # -# Copyright (c) 1998-2000 - Dirk Koopman G1TLH +# Copyright (c) 1998-2016 - Dirk Koopman G1TLH # # # @@ -80,12 +80,14 @@ $count = 0; wcyfilter => '5,WCY Filt-out', spotsfilter => '5,Spot Filt-out', routefilter => '5,Route Filt-out', + rbnfilter => '5,RBN Filt-out', pc92filter => '5,PC92 Route Filt-out', inannfilter => '5,Ann Filt-inp', inwwvfilter => '5,WWV Filt-inp', inwcyfilter => '5,WCY Filt-inp', inspotsfilter => '5,Spot Filt-inp', inroutefilter => '5,Route Filt-inp', + inrbnfilter => '5,RBN Filt-inp', inpc92filter => '5,PC92 Route Filt-inp', passwd => '9,Passwd List,yesno', pingint => '5,Ping Interval ', @@ -125,6 +127,9 @@ $count = 0; inqueue => '9,Input Queue,parray', next_pc92_update => '9,Next PC92 Update,atime', next_pc92_keepalive => '9,Next PC92 KeepAlive,atime', + hostname => '0,Hostname', + isslugged => '9,Still Slugged,yesno', + sluggedpcs => '9,Slugged PCxx Queue,parray', ); $maxerrors = 20; # the maximum number of concurrent errors allowed before disconnection @@ -161,20 +166,19 @@ sub alloc $self->{sort} = $user->sort; $self->{width} = $user->width; } - $self->{startt} = $self->{t} = time; + $self->{startt} = $self->{t} = $main::systime; $self->{state} = 0; $self->{oldstate} = 0; $self->{lang} = $main::lang if !$self->{lang}; $self->{func} = ""; $self->{width} ||= 80; - # add in all the dxcc, itu, zone info my @dxcc = Prefix::extract($call); if (@dxcc > 0) { $self->{dxcc} = $dxcc[1]->dxcc; $self->{itu} = $dxcc[1]->itu; - $self->{cq} = $dxcc[1]->cq; + $self->{cq} = $dxcc[1]->cq; } $self->{inqueue} = []; @@ -216,6 +220,7 @@ sub rec if (defined $msg) { push @{$self->{inqueue}}, $msg; } + $self->process_one; } # obtain a channel object by callsign [$obj = DXChannel::get($call)] @@ -301,69 +306,65 @@ 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'; } # 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 +503,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 +590,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 +682,7 @@ sub broadcast_list if ($sort eq 'dx') { next unless $dxchan->{dx}; - ($filter) = $dxchan->{spotsfilter}->it(@{$fref}) if ref $fref; + ($filter) = $dxchan->{spotsfilter}->it($fref) if $dxchan->{spotsfilter} && ref $fref; next unless $filter; } next if $sort eq 'ann' && !$dxchan->{ann} && $s !~ /^To\s+LOCAL\s+de\s+(?:$main::myalias|$main::mycall)/i; @@ -699,42 +700,48 @@ sub broadcast_list } } -sub process +sub process_one { - foreach my $dxchan (get_all()) { - next if $dxchan->{disconnecting}; + my $self = shift; + + while (my $data = shift @{$self->{inqueue}}) { + my ($sort, $call, $line) = $self->decode_input($data); + next unless defined $sort; + + # 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'); - 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; + # handle A records + my $user = $self->user; + if ($sort eq 'I') { + die "\$user not defined for $call" unless defined $user; - # normal input - $dxchan->normal($line); - } elsif ($sort eq 'Z') { - $dxchan->disconnect; - } elsif ($sort eq 'D') { - ; # ignored (an echo) - } elsif ($sort eq 'C') { - $dxchan->width($line); # change number of columns - } elsif ($sort eq 'G') { - $dxchan->enhanced($line); - } else { - print STDERR atime, " Unknown command letter ($sort) received from $call\n"; - } + # normal input + $self->normal($line); + } elsif ($sort eq 'G') { + $self->enhanced($line); + } elsif ($sort eq 'A' || $sort eq 'O' || $sort eq 'W') { + $self->start($line, $sort); + } elsif ($sort eq 'C') { + $self->width($line); # change number of columns + } elsif ($sort eq 'Z') { + $self->disconnect; + } elsif ($sort eq 'D') { + ; # ignored (an echo) + } else { + dbg atime . " DXChannel::process_one: Unknown command letter ($sort) received from $call\n"; } } } +sub process +{ + foreach my $dxchan (values %channels) { + next if $dxchan->{disconnecting}; + $dxchan->process_one; + } +} + sub handle_xml { my $self = shift; @@ -748,12 +755,22 @@ sub handle_xml return $r; } -sub registered +sub error_handler +{ + my $self = shift; + my $error = shift || ''; + dbg("$self->{call} ERROR '$error', closing") if isdbg('chan'); + $self->{conn}->set_error(undef) if exists $self->{conn}; + $self->disconnect(1); +} + + +sub isregistered { my $self = shift; # the sysop is registered! - return 1 if $self->call eq $main::myalias || $self->call eq $main::mycall; + return 1 if $self->{call} eq $main::myalias || $self->{call} eq $main::mycall; if ($main::reqreg) { return $self->{registered}; diff --git a/perl/DXMsg.pm b/perl/DXMsg.pm index e6662b59..174a98a4 100644 --- a/perl/DXMsg.pm +++ b/perl/DXMsg.pm @@ -216,7 +216,7 @@ sub handle_29 my $ref = get_fwq($fromnode, $stream); if ($ref) { - $_[4] =~ s/\%5E/^/g; + $_[4] =~ s/\%5E/~/g; if (@{$ref->{lines}}) { push @{$ref->{lines}}, $_[4]; } else { @@ -786,6 +786,8 @@ sub queue_msg if ($dxchan) { if ($dxchan->is_node) { next if $clref->call eq $main::mycall; # i.e. it lives here + next if $dxchan->is_arcluster; # don't even go there, idiot people send the header in the wrong order and won't/can't fix it + next if $dxchan->isolate; # there is no mechanism for sending messages to isolated nodes. $ref->start_msg($dxchan) if !get_busy($dxchan->call) && $dxchan->state eq 'normal'; } } else { @@ -804,8 +806,10 @@ sub queue_msg next unless $call; next if $call eq $main::mycall; next if ref $ref->{gotit} && grep $_ eq $call, @{$ref->{gotit}}; - next unless $ref->forward_it($call); # check the forwarding file - next if $ref->{tonode}; # ignore it if it already being processed + next unless $ref->forward_it($call); # check the forwarding file + next if $ref->{tonode}; # ignore it if it already being processed + next if $dxchan->is_arcluster; # don't even go there, idiot people send the header in the wrong order and won't/can't fix it + next if $dxchan->isolate; # there is no mechanism for sending messages to isolated nodes. # if we are here we have a node that doesn't have this message if (!get_busy($call) && $dxchan->state eq 'normal') { diff --git a/perl/DXProt.pm b/perl/DXProt.pm index 09ab5451..3da7117f 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -34,6 +34,8 @@ use Route::Node; use Script; use DXProtHandle; +use Time::HiRes qw(gettimeofday tv_interval); + use strict; use vars qw($pc11_max_age $pc23_max_age $last_pc50 $eph_restime $eph_info_restime $eph_pc34_restime @@ -174,6 +176,8 @@ $pc92_find_timeout = 30; # maximum time to wait for a reply sub check { my $n = shift; + my $pc = shift; + $n -= 10; return 0 if $n < 0 || $n > @checklist; my $ref = $checklist[$n]; @@ -183,30 +187,30 @@ sub check for ($i = 1; $i < @$ref; $i++) { my ($blank, $act) = $$ref[$i] =~ /^(b?)(\w)$/; return 0 unless $act; - next if $blank eq 'b' && $_[$i] =~ /^[ \*]$/; - next if $blank eq '*' && $_[$i] =~ /^\*$/; + next if $blank eq 'b' && $pc->[$i] =~ /^[ \*]$/; + next if $blank eq '*' && $pc->[$i] =~ /^\*$/; if ($act eq 'c') { - return $i unless is_callsign($_[$i]); + return $i unless is_callsign($pc->[$i]); } elsif ($act eq 'i') { ; # do nothing } elsif ($act eq 'm') { - return $i unless is_pctext($_[$i]); + return $i unless is_pctext($pc->[$i]); } elsif ($act eq 'p') { - return $i unless is_pcflag($_[$i]); + return $i unless is_pcflag($pc->[$i]); } elsif ($act eq 'f') { - return $i unless is_freq($_[$i]); + return $i unless is_freq($pc->[$i]); } elsif ($act eq 'n') { - return $i unless $_[$i] =~ /^[\d ]+$/; + return $i unless $pc->[$i] =~ /^[\d ]+$/; } elsif ($act eq 'h') { - return $i unless $_[$i] =~ /^H\d\d?$/; + return $i unless $pc->[$i] =~ /^H\d\d?$/; } elsif ($act eq 'd') { - return $i unless $_[$i] =~ /^\s*\d+-\w\w\w-[12][90]\d\d$/; + return $i unless $pc->[$i] =~ /^\s*\d+-\w\w\w-[12][90]\d\d$/; } elsif ($act eq 't') { - return $i unless $_[$i] =~ /^[012]\d[012345]\dZ$/; + return $i unless $pc->[$i] =~ /^[012]\d[012345]\dZ$/; } elsif ($act eq 'l') { - return $i unless $_[$i] =~ /^[A-Z]$/; + return $i unless $pc->[$i] =~ /^[A-Z]$/; } elsif ($act eq 'a') { - return $i unless is_ipaddr($_[$i]); + return $i unless is_ipaddr($pc->[$i]); } } return 0; @@ -230,7 +234,8 @@ sub update_pc92_keepalive sub init { - do "$main::data/hop_table.pl" if -e "$main::data/hop_table.pl"; + my $fn = localdata("hop_table.pl"); + do $fn if -e $fn; confess $@ if $@; my $user = DXUser::get($main::mycall); @@ -246,8 +251,9 @@ sub init $main::me->{pingave} = 0; $main::me->{registered} = 1; $main::me->{version} = $main::version; - $main::me->{build} = "$main::subversion.$main::build"; + $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; } @@ -289,6 +295,7 @@ sub start my $host = $self->{conn}->peerhost; $host ||= "AGW Port #$self->{conn}->{agwport}" if exists $self->{conn}->{agwport}; $host ||= "unknown"; + $self->{hostname} = $host if is_ipaddr($host); Log('DXProt', "$call connected from $host"); @@ -401,7 +408,7 @@ sub normal } # check for and dump bad protocol messages - my $n = check($pcno, @field); + my $n = check($pcno, \@field); if ($n) { dbg("PCPROT: bad field $n, dumped (" . parray($checklist[$pcno-10]) . ")") if isdbg('chanerr'); return; @@ -430,9 +437,9 @@ sub normal my $sub = "handle_$pcno"; if ($self->can($sub)) { - $self->$sub($pcno, $line, $origin, @field); + $self->$sub($pcno, $line, $origin, \@field); } else { - $self->handle_default($pcno, $line, $origin, @field); + $self->handle_default($pcno, $line, $origin, \@field); } } @@ -529,6 +536,8 @@ sub process if ($main::systime - 3600 > $last_hour) { $last_hour = $main::systime; } + + pc11_process(); } # @@ -553,6 +562,8 @@ sub send_dx_spot foreach $dxchan (@dxchan) { next if $dxchan == $main::me; next if $dxchan == $self && $self->is_node; + next if $dxchan == $self; + next if $dxchan->is_rbn; if ($line =~ /PC61/ && !($dxchan->is_spider || $dxchan->is_user)) { unless ($pc11) { my @f = split /\^/, $line; @@ -613,6 +624,7 @@ sub send_wwv_spot foreach $dxchan (@dxchan) { next if $dxchan == $main::me; next if $dxchan == $self && $self->is_node; + next if $dxchan->is_rbn; my $routeit; my ($filter, $hops); @@ -647,6 +659,7 @@ sub send_wcy_spot foreach $dxchan (@dxchan) { next if $dxchan == $main::me; next if $dxchan == $self; + next if $dxchan->is_rbn; $dxchan->wcy($line, $self->{isolate}, @_, $self->{call}, @dxcc); } @@ -730,6 +743,7 @@ sub send_announce next if $dxchan == $self && $self->is_node; next if $from_pc9x && $dxchan->{do_pc9x}; next if $target eq 'LOCAL' && $dxchan->is_node; + next if $dxchan->is_rbn; $dxchan->announce($line, $self->{isolate}, $to, $target, $text, @_, $self->{call}, @a[0..2], @b[0..2]); } @@ -802,6 +816,7 @@ sub send_chat next unless $dxchan->is_spider && $dxchan->do_pc9x; next if $target eq 'LOCAL'; } + next if $dxchan->is_rbn; $dxchan->chat($line, $self->{isolate}, $target, $_[1], $text, @_, $self->{call}, @a[0..2], @b[0..2]); @@ -858,11 +873,11 @@ sub send_local_config my @remotenodes; if ($self->{isolate}) { - dbg("send_local_config: isolated"); + dbg("$self->{call} send_local_config: isolated"); @localnodes = ( $main::routeroot ); $self->send_route($main::mycall, \&pc19, 1, $main::routeroot); } elsif ($self->{do_pc9x}) { - dbg("send_local_config: doing pc9x"); + dbg("$self->{call} send_local_config: doing pc9x"); my $node = Route::Node::get($self->{call}); # $self->send_last_pc92_config($main::routeroot); # $self->send(pc92a($main::routeroot, $node)) unless $main::routeroot->last_PC92C =~ /$self->{call}/; @@ -873,7 +888,7 @@ sub send_local_config # and are not themselves isolated, this to make sure that isolated nodes # don't appear outside of this node - dbg("send_local_config: traditional"); + dbg("$self->{call} send_local_config: traditional"); # send locally connected nodes my @dxchan = grep { $_->call ne $main::mycall && $_ != $self && !$_->{isolate} } DXChannel::get_all_nodes(); @@ -915,7 +930,7 @@ sub gen_my_pc92_config clear_pc92_changes(); # remove any slugged data, we are generating it as now my @dxchan = grep { $_->call ne $main::mycall && !$_->{isolate} } DXChannel::get_all(); dbg("ROUTE: all dxchan: " . join(',', map{$_->{call}} @dxchan)) if isdbg('routelow'); - my @localnodes = map { my $r = Route::get($_->{call}); $r ? $r : () } @dxchan; + my @localnodes = map { my $r = Route::get($_->{call}); ($_->is_node || $_->is_user) && $r ? $r : () } @dxchan; dbg("ROUTE: localnodes: " . join(',', map{$_->{call}} @localnodes)) if isdbg('routelow'); return pc92c($node, @localnodes); } else { @@ -1111,6 +1126,7 @@ sub load_hops sub process_rcmd { my ($self, $tonode, $fromnode, $user, $cmd) = @_; + if ($tonode eq $main::mycall) { my $ref = DXUser::get_current($fromnode); unless ($ref && UNIVERSAL::isa($ref, 'DXUser')) { @@ -1118,19 +1134,25 @@ sub process_rcmd $self->send_rcmd_reply($main::mycall, $fromnode, $user, "sorry...!"); return; } + Log('rcmd', 'in', ($ref->{priv}||0), $fromnode, $cmd, $user); my $cref = Route::Node::get($fromnode); unless ($cref && UNIVERSAL::isa($cref, 'Route')) { dbg("DXProt process_rcmd: Route $fromnode isn't a reference (tell G1TLH)"); $self->send_rcmd_reply($main::mycall, $fromnode, $user, "sorry...!"); return; } - Log('rcmd', 'in', ($ref->{priv}||0), $fromnode, $cmd); if ($cmd !~ /^\s*rcmd/i && $ref->homenode && $cref->call eq $ref->homenode) { # not allowed to relay RCMDS! if ($ref->{priv}) { # you have to have SOME privilege, the commands have further filtering $self->{remotecmd} = 1; # for the benefit of any command that needs to know my $oldpriv = $self->{priv}; - $self->{priv} = $ref->{priv}; # assume the user's privilege level + $self->{priv} = 1; # set a maximum privilege + + # park homenode and user for any spawned command that run_cmd may do. + $self->{_rcmd_user} = $user; + $self->{_rcmd_fromnode} = $fromnode; my @in = (DXCommandmode::run_cmd($self, $cmd)); + delete $self->{_rcmd_fromnode}; + delete $self->{_rcmd_user}; $self->{priv} = $oldpriv; $self->send_rcmd_reply($main::mycall, $fromnode, $user, @in); delete $self->{remotecmd}; @@ -1150,6 +1172,26 @@ sub process_rcmd } } + +sub send_rcmd_reply +{ + my $self = shift; + my $tonode = shift; + my $fromnode = shift; + my $user = shift; + while (@_) { + my $line = shift; + $line =~ s/\s*$//; + Log('rcmd', 'out', $fromnode, $line, $user); + if ($self->is_clx) { + $self->send(pc85($main::mycall, $fromnode, $user, "$main::mycall:$line")); + } else { + $self->send(pc35($main::mycall, $fromnode, "$main::mycall:$line")); + } + } +} + + sub process_rcmd_reply { my ($self, $tonode, $fromnode, $user, $line) = @_; @@ -1175,23 +1217,7 @@ sub process_rcmd_reply } } -sub send_rcmd_reply -{ - my $self = shift; - my $tonode = shift; - my $fromnode = shift; - my $user = shift; - while (@_) { - my $line = shift; - $line =~ s/\s*$//; - Log('rcmd', 'out', $fromnode, $line); - if ($self->is_clx) { - $self->send(pc85($main::mycall, $fromnode, $user, "$main::mycall:$line")); - } else { - $self->send(pc35($main::mycall, $fromnode, "$main::mycall:$line")); - } - } -} + # add a rcmd request to the rcmd queues sub addrcmd @@ -1686,5 +1712,8 @@ sub clean_pc92_find { } + + + 1; __END__ diff --git a/perl/DXProtHandle.pm b/perl/DXProtHandle.pm index b3a7cfcd..c4344339 100644 --- a/perl/DXProtHandle.pm +++ b/perl/DXProtHandle.pm @@ -49,11 +49,11 @@ use vars qw($pc11_max_age $pc23_max_age $last_pc50 $eph_restime $eph_info_restim $pc9x_dupe_age = 60; # catch loops of circular (usually) D records $pc10_dupe_age = 45; # just something to catch duplicate PC10->PC93 conversions -$pc92_slug_changes = 60*5; # slug any changes going outward for this long +$pc92_slug_changes = 60*1; # slug any changes going outward for this long $last_pc92_slug = 0; # the last time we sent out any delayed add or del PC92s $pc9x_time_tolerance = 15*60; # the time on a pc9x is allowed to be out by this amount $pc9x_past_age = (122*60)+ # maximum age in the past of a px9x (a config record might be the only - $pc9x_time_tolerance; # thing a node might send - once an hour and we allow an extra hour for luck) +$pc9x_time_tolerance; # thing a node might send - once an hour and we allow an extra hour for luck) # this is actually the partition between "yesterday" and "today" but old. $pc92filterdef = bless ([ @@ -65,6 +65,10 @@ $pc92filterdef = bless ([ ['zone', 'nz', 3], ], 'Filter::Cmd'); +our %pc11q; +# this is a place to park an incoming PC11 in the sure and certain hope that +# a PC61 will be along soon. This has the side benefit that it will delay a +# a PC11 for one second - assuming that it is not removed by a PC61 version # incoming talk commands sub handle_10 @@ -73,6 +77,7 @@ sub handle_10 my $pcno = shift; my $line = shift; my $origin = shift; + my $pc = shift; # this is to catch loops caused by bad software ... if (eph_dup($line, $pc10_dupe_age)) { @@ -82,7 +87,7 @@ sub handle_10 # will we allow it at all? if ($censorpc) { my @bad; - if (@bad = BadWords::check($_[3])) { + if (@bad = BadWords::check($pc->[3])) { dbg("PCPROT: Bad words: @bad, dropped") if isdbg('chanerr'); return; } @@ -90,16 +95,16 @@ sub handle_10 # is it for me or one of mine? my ($from, $to, $via, $call, $dxchan); - $from = $_[1]; - if ($_[5] gt ' ') { - $via = $_[2]; - $to = $_[5]; + $from = $pc->[1]; + if ($pc->[5] gt ' ') { + $via = $pc->[2]; + $to = $pc->[5]; } else { - $to = $_[2]; + $to = $pc->[2]; } # if this is a 'nodx' node then ignore it - if ($badnode->in($_[6]) || ($via && $badnode->in($via))) { + if ($badnode->in($pc->[6]) || ($via && $badnode->in($via))) { dbg("PCPROT: Bad Node, dropped") if isdbg('chanerr'); return; } @@ -114,16 +119,18 @@ sub handle_10 # if we are converting announces to talk is it a dup? if ($ann_to_talk) { - if (AnnTalk::is_talk_candidate($from, $_[3]) && AnnTalk::dup($from, $to, $_[3])) { + if (AnnTalk::is_talk_candidate($from, $pc->[3]) && AnnTalk::dup($from, $to, $pc->[3])) { dbg("PCPROT: Dupe talk from announce, dropped") if isdbg('chanerr'); return; } } # convert this to a PC93, coming from mycall with origin set and process it as such - $main::me->normal(pc93($to, $from, $via, $_[3], $_[6])); + $main::me->normal(pc93($to, $from, $via, $pc->[3], $pc->[6])); } +my $last; + # DX Spot handling sub handle_11 { @@ -131,73 +138,79 @@ sub handle_11 my $pcno = shift; my $line = shift; my $origin = shift; + my $pc = shift; # route 'foreign' pc26s if ($pcno == 26) { - if ($_[7] ne $main::mycall) { - $self->route($_[7], $line); + if ($pc->[7] ne $main::mycall) { + $self->route($pc->[7], $line); return; } } -# my ($hops) = $_[8] =~ /^H(\d+)/; +# my ($hops) = $pc->[8] =~ /^H(\d+)/; # is the spotted callsign blank? This should really be trapped earlier but it # could break other protocol sentences. Also check for lower case characters. - if ($_[2] =~ /^\s*$/) { + if ($pc->[2] =~ /^\s*$/) { dbg("PCPROT: blank callsign, dropped") if isdbg('chanerr'); return; } - if ($_[2] =~ /[a-z]/) { + if ($pc->[2] =~ /[a-z]/) { dbg("PCPROT: lowercase characters, dropped") if isdbg('chanerr'); return; } # if this is a 'nodx' node then ignore it - if ($badnode->in($_[7])) { - dbg("PCPROT: Bad Node, dropped") if isdbg('chanerr'); + if ($badnode->in($pc->[7])) { + dbg("PCPROT: Bad Node $pc->[7], dropped") if isdbg('chanerr'); return; } - # if this is a 'bad spotter' user then ignore it - my $nossid = $_[6]; + # if this is a 'bad spotter' or an unknown user then ignore it. BUT if it's got an IP address then allow it through + my $nossid = $pc->[6]; $nossid =~ s/-\d+$//; if ($badspotter->in($nossid)) { - dbg("PCPROT: Bad Spotter, dropped") if isdbg('chanerr'); + dbg("PCPROT: Bad Spotter $pc->[6], dropped") if isdbg('chanerr'); return; } +# unless (is_ipaddr($pc->[8]) || DXUser::get_current($pc->[6])) { +# dbg("PCPROT: Unknown Spotter $pc->[6], dropped") if isdbg('chanerr'); +# return; +# } # convert the date to a unix date - my $d = cltounix($_[3], $_[4]); + my $d = cltounix($pc->[3], $pc->[4]); # bang out (and don't pass on) if date is invalid or the spot is too old (or too young) if (!$d || (($pcno == 11 || $pcno == 61) && ($d < $main::systime - $pc11_max_age || $d > $main::systime + 900))) { - dbg("PCPROT: Spot ignored, invalid date or out of range ($_[3] $_[4])\n") if isdbg('chanerr'); + dbg("PCPROT: Spot ignored, invalid date or out of range ($pc->[3] $pc->[4])\n") if isdbg('chanerr'); return; } # is it 'baddx' - if ($baddx->in($_[2]) || BadWords::check($_[2])) { + if ($baddx->in($pc->[2]) || BadWords::check($pc->[2])) { dbg("PCPROT: Bad DX spot, ignored") if isdbg('chanerr'); return; } # do some de-duping - $_[5] =~ s/^\s+//; # take any leading blanks off - $_[2] = unpad($_[2]); # take off leading and trailing blanks from spotted callsign - if ($_[2] =~ /BUST\w*$/) { + $pc->[5] =~ s/^\s+//; # take any leading blanks off + $pc->[2] = unpad($pc->[2]); # take off leading and trailing blanks from spotted callsign + if ($pc->[2] =~ /BUST\w*$/) { dbg("PCPROT: useless 'BUSTED' spot") if isdbg('chanerr'); return; } if ($censorpc) { my @bad; - if (@bad = BadWords::check($_[5])) { + if (@bad = BadWords::check($pc->[5])) { dbg("PCPROT: Bad words: @bad, dropped") if isdbg('chanerr'); return; } } - my @spot = Spot::prepare($_[1], $_[2], $d, $_[5], $nossid, $_[7], $_[8]); + my @spot = Spot::prepare($pc->[1], $pc->[2], $d, $pc->[5], $nossid, $pc->[7], $pc->[8]); + # global spot filtering on INPUT if ($self->{inspotsfilter}) { my ($filter, $hops) = $self->{inspotsfilter}->it(@spot); @@ -207,17 +220,75 @@ sub handle_11 } } + # If is a new PC11, store it, releasing the one that is there (if any), + # if a PC61 comes along then dump the stored PC11 + # If there is a different PC11 stored, release that one and store this PC11 instead, + my $key = join '|', @spot[0..2,4,7]; + if (0) { + + if ($pc->[0] eq 'PC11') { + my $r = [$main::systime, $key, \@spot, $line, $origin, $pc]; + if (!$last) { + $last = [$main::systime, $key, \@spot, $line, $origin, $pc]; + dbg("PC11: $origin -> $key stored") if isdbg('pc11'); + return; + } elsif ($key eq $last->[1]) { # same as last one + dbg("PC11: $origin -> $key dupe dropped") if isdbg('pc11'); + return; + } else { + # it's a different PC11, kick the stored one onward and store this one instead, + dbg("PC11: PC11 new $origin -> $key stored, $last->[4] -> $last->[1] passed onward") if isdbg('pc11'); + @spot = @{$last->[2]}; + $line = $last->[3]; + $origin = $last->[4]; + $pc = $last->[5]; + $last = $r; + } + } elsif ($pc->[0] eq 'PC61') { + if ($last) { + if ($last->[1] eq $key) { + # dump $last and proceed with the PC61 + dbg("PC11: $origin -> $key dropped in favour of PC61") if isdbg('pc11'); + undef $last; + } else { + # it's a different spot send out stored pc11 + dbg("PC11: last $last->[4] -> $last->[1] different PC61 $origin -> $key, send PC11 first ") if isdbg('pc11'); + $last->[1] = 'new pc61'; + handle_11($self, 11, $last->[3], $last->[4], $last->[5]); + undef $last; + dbg("PC11: now process PC61 $origin -> $key") if isdbg('pc11'); + } + } + } else { + dbg("PC11: Unexpected line '$line' in bagging area (expecting PC61, PC11), ignored"); + return; + } + +} + # this goes after the input filtering, but before the add # so that if it is input filtered, it isn't added to the dup # list. This allows it to come in from a "legitimate" source if (Spot::dup(@spot[0..4,5])) { - dbg("PCPROT: Duplicate Spot ignored\n") if isdbg('chanerr'); + dbg("PCPROT: Duplicate Spot $pc->[0] $key ignored\n") if isdbg('chanerr') || isdbg('dupespot'); return; } - + # add it Spot::add(@spot); + my $ip = ''; + $ip ||= $spot[14] if exists $spot[14]; + if (isdbg('progress')) { + my $sip = $ip ? sprintf "($ip)" : '' unless $ip =~ m|[\(\)\*]|; + $sip ||= ''; + my $d = ztime($spot[2]); + my $s = "SPOT: $spot[1] on $spot[0] \@ $d by $spot[4]$sip\@$spot[7]"; + $s .= $spot[3] ? " '$spot[3]'" : q{ ''}; + $s .= " route: $origin"; + dbg($s); + } + # # @spot at this point contains:- # freq, spotted call, time, text, spotter, spotted cc, spotters cc, orig node @@ -254,8 +325,8 @@ sub handle_11 } else { route(undef, $to, pc34($main::mycall, $to, $cmd)); } - if ($to ne $_[7]) { - $to = $_[7]; + if ($to ne $origin) { + $to = $origin; $node = Route::Node::get($to); if ($node) { $dxchan = $node->dxchan; @@ -288,6 +359,12 @@ sub handle_11 send_dx_spot($self, $line, @spot) if @spot; } +# used to kick outstanding PC11 if required +sub pc11_process +{ + +} + # announces sub handle_12 { @@ -295,26 +372,27 @@ sub handle_12 my $pcno = shift; my $line = shift; my $origin = shift; + my $pc = shift; # announce duplicate checking - $_[3] =~ s/^\s+//; # remove leading blanks + $pc->[3] =~ s/^\s+//; # remove leading blanks if ($censorpc) { my @bad; - if (@bad = BadWords::check($_[3])) { + if (@bad = BadWords::check($pc->[3])) { dbg("PCPROT: Bad words: @bad, dropped") if isdbg('chanerr'); return; } } # if this is a 'nodx' node then ignore it - if ($badnode->in($_[5])) { + if ($badnode->in($pc->[5])) { dbg("PCPROT: Bad Node, dropped") if isdbg('chanerr'); return; } # if this is a 'bad spotter' user then ignore it - my $nossid = $_[1]; + my $nossid = $pc->[1]; $nossid =~ s/-\d+$//; if ($badspotter->in($nossid)) { dbg("PCPROT: Bad Spotter, dropped") if isdbg('chanerr'); @@ -330,13 +408,13 @@ sub handle_12 my $dxchan; - if ((($dxchan = DXChannel::get($_[2])) && $dxchan->is_user) || $_[4] =~ /^[\#\w.]+$/){ - $self->send_chat(0, $line, @_[1..6]); - } elsif ($_[2] eq '*' || $_[2] eq $main::mycall) { + if ((($dxchan = DXChannel::get($pc->[2])) && $dxchan->is_user) || $pc->[4] =~ /^[\#\w.]+$/){ + $self->send_chat(0, $line, @$pc[1..6]); + } elsif ($pc->[2] eq '*' || $pc->[2] eq $main::mycall) { # ignore something that looks like a chat line coming in with sysop # flag - this is a kludge... - if ($_[3] =~ /^\#\d+ / && $_[4] eq '*') { + if ($pc->[3] =~ /^\#\d+ / && $pc->[4] eq '*') { dbg('PCPROT: Probable chat rewrite, dropped') if isdbg('chanerr'); return; } @@ -344,28 +422,28 @@ sub handle_12 # here's a bit of fun, convert incoming ann with a callsign in the first word # or one saying 'to ' to a talk if we can route to the recipient if ($ann_to_talk) { - my $call = AnnTalk::is_talk_candidate($_[1], $_[3]); + my $call = AnnTalk::is_talk_candidate($pc->[1], $pc->[3]); if ($call) { my $ref = Route::get($call); if ($ref) { $dxchan = $ref->dxchan; - $dxchan->talk($_[1], $call, undef, $_[3], $_[5]) if $dxchan != $self; + $dxchan->talk($pc->[1], $call, undef, $pc->[3], $pc->[5]) if $dxchan != $self; return; } } } # send it - $self->send_announce(0, $line, @_[1..6]); + $self->send_announce(0, $line, @$pc[1..6]); } else { - $self->route($_[2], $line); + $self->route($pc->[2], $line); } # local processing if (defined &Local::ann) { my $r; eval { - $r = Local::ann($self, $line, @_[1..6]); + $r = Local::ann($self, $line, @$pc[1..6]); }; return if $r; } @@ -377,6 +455,7 @@ sub handle_15 my $pcno = shift; my $line = shift; my $origin = shift; + my $pc = shift; if (eph_dup($line, $eph_pc15_restime)) { return; @@ -394,10 +473,11 @@ sub handle_16 my $pcno = shift; my $line = shift; my $origin = shift; + my $pc = shift; # general checks my $dxchan; - my $ncall = $_[1]; + my $ncall = $pc->[1]; my $newline = "PC16^"; # dos I want users from this channel? @@ -453,8 +533,8 @@ sub handle_16 my $i; my @rout; - for ($i = 2; $i < $#_; $i++) { - my ($call, $conf, $here) = $_[$i] =~ /^(\S+) (\S) (\d)/o; + for ($i = 2; $i < $#$pc; $i++) { + my ($call, $conf, $here) = $pc->[$i] =~ /^(\S+) (\S) (\d)/o; next unless $call && $conf && defined $here && is_callsign($call); next if $call eq $main::mycall; @@ -510,9 +590,11 @@ sub handle_17 my $pcno = shift; my $line = shift; my $origin = shift; + my $pc = shift; + my $dxchan; - my $ncall = $_[2]; - my $ucall = $_[1]; + my $ncall = $pc->[2]; + my $ucall = $pc->[1]; eph_del_regex("^PC16\\^$ncall.*$ucall"); @@ -586,42 +668,44 @@ sub handle_18 my $pcno = shift; my $line = shift; my $origin = shift; + my $pc = shift; + $self->state('init'); my $parent = Route::Node::get($self->{call}); # record the type and version offered - if (my ($version) = $_[1] =~ /DXSpider Version: (\d+\.\d+)/) { + if (my ($version) = $pc->[1] =~ /DXSpider Version: (\d+\.\d+)/) { $self->{version} = 53 + $version; $self->user->version(53 + $version); $parent->version(0 + $version); - my ($build) = $_[1] =~ /Build: (\d+(?:\.\d+)?)/; + my ($build) = $pc->[1] =~ /Build: (\d+(?:\.\d+)?)/; $self->{build} = 0 + $build; $self->user->build(0 + $build); $parent->build(0 + $build); - dbg("DXSpider version $version build $build"); + dbg("$self->{call} = DXSpider version $version build $build"); unless ($self->is_spider) { dbg("Change U " . $self->user->sort . " C $self->{sort} -> S"); $self->user->sort('S'); $self->user->put; $self->sort('S'); } -# $self->{handle_xml}++ if DXXml::available() && $_[1] =~ /\bxml/; +# $self->{handle_xml}++ if DXXml::available() && $pc->[1] =~ /\bxml/; } else { - dbg("Unknown software"); + dbg("$self->{call} = Unknown software ($pc->[1] $pc->[2])"); $self->version(50.0); - $self->version($_[2] / 100) if $_[2] && $_[2] =~ /^\d+$/; + $self->version($pc->[2] / 100) if $pc->[2] && $pc->[2] =~ /^\d+$/; $self->user->version($self->version); } - if ($_[1] =~ /\bpc9x/) { + if ($pc->[1] =~ /\bpc9x/) { if ($self->{isolate}) { - dbg("pc9x recognised, but $self->{call} is isolated, using old protocol"); + dbg("$self->{call} pc9x recognised, but node is isolated, using old protocol"); } elsif (!$self->user->wantpc9x) { - dbg("pc9x explicitly switched off on $self->{call}, using old protocol"); + dbg("$self->{call} pc9x explicitly switched off, using old protocol"); } else { $self->{do_pc9x} = 1; - dbg("Do px9x set on $self->{call}"); + dbg("$self->{call} Set do PC9x"); } } @@ -638,13 +722,15 @@ sub check_add_node # add this station to the user database, if required (don't remove SSID from nodes) my $user = DXUser::get_current($call); - if (!$user) { + unless ($user) { $user = DXUser->new($call); $user->priv(1); # I have relented and defaulted nodes $user->lockout(1); $user->homenode($call); $user->node($call); $user->sort('A'); + $user->lastin($main::systime); # this make it last longer than just this invocation + $user->put; # just to make sure it gets written away!!! } return $user; } @@ -656,6 +742,7 @@ sub handle_19 my $pcno = shift; my $line = shift; my $origin = shift; + my $pc = shift; my $i; my $newline = "PC19^"; @@ -685,11 +772,11 @@ sub handle_19 # From now on we are only going to believe PC92 data and locally connected # non-pc92 nodes. # - for ($i = 1; $i < $#_-1; $i += 4) { - my $here = $_[$i]; - my $call = uc $_[$i+1]; - my $conf = $_[$i+2]; - my $ver = $_[$i+3]; + for ($i = 1; $i < $#$pc-1; $i += 4) { + my $here = $pc->[$i]; + my $call = uc $pc->[$i+1]; + my $conf = $pc->[$i+2]; + my $ver = $pc->[$i+3]; next unless defined $here && defined $conf && is_callsign($call); eph_del_regex("^PC(?:21\\^$call|17\\^[^\\^]+\\^$call)"); @@ -794,6 +881,7 @@ sub handle_20 my $pcno = shift; my $line = shift; my $origin = shift; + my $pc = shift; if ($self->{do_pc9x} && $self->{state} ne 'init92') { $self->send("Reseting to oldstyle routing because login call not sent in any pc92"); @@ -816,7 +904,9 @@ sub handle_21 my $pcno = shift; my $line = shift; my $origin = shift; - my $call = uc $_[1]; + my $pc = shift; + + my $call = uc $pc->[1]; eph_del_regex("^PC1[679].*$call"); @@ -884,6 +974,7 @@ sub handle_22 my $pcno = shift; my $line = shift; my $origin = shift; + my $pc = shift; if ($self->{do_pc9x}) { if ($self->{state} ne 'init92') { @@ -903,50 +994,52 @@ sub handle_23 my $pcno = shift; my $line = shift; my $origin = shift; + my $pc = shift; # route foreign' pc27s if ($pcno == 27) { - if ($_[8] ne $main::mycall) { - $self->route($_[8], $line); + if ($pc->[8] ne $main::mycall) { + $self->route($pc->[8], $line); return; } } # do some de-duping - my $d = cltounix($_[1], sprintf("%02d18Z", $_[2])); - my $sfi = unpad($_[3]); - my $k = unpad($_[4]); - my $i = unpad($_[5]); - my ($r) = $_[6] =~ /R=(\d+)/; + my $d = cltounix($pc->[1], sprintf("%02d18Z", $pc->[2])); + my $sfi = unpad($pc->[3]); + my $k = unpad($pc->[4]); + my $i = unpad($pc->[5]); + my ($r) = $pc->[6] =~ /R=(\d+)/; $r = 0 unless $r; - if (($pcno == 23 && $d < $main::systime - $pc23_max_age) || $d > $main::systime + 1500 || $_[2] < 0 || $_[2] > 23) { - dbg("PCPROT: WWV Date ($_[1] $_[2]) out of range") if isdbg('chanerr'); + if (($pcno == 23 && $d < $main::systime - $pc23_max_age) || $d > $main::systime + 1500 || $pc->[2] < 0 || $pc->[2] > 23) { + dbg("PCPROT: WWV Date ($pc->[1] $pc->[2]) out of range") if isdbg('chanerr'); return; } # global wwv filtering on INPUT - my @dxcc = ((Prefix::cty_data($_[7]))[0..2], (Prefix::cty_data($_[8]))[0..2]); + my @dxcc = ((Prefix::cty_data($pc->[7]))[0..2], (Prefix::cty_data($pc->[8]))[0..2]); if ($self->{inwwvfilter}) { - my ($filter, $hops) = $self->{inwwvfilter}->it(@_[7,8], $origin, @dxcc); + my ($filter, $hops) = $self->{inwwvfilter}->it(@$pc[7,8], $origin, @dxcc); unless ($filter) { dbg("PCPROT: Rejected by input wwv filter") if isdbg('chanerr'); return; } } - $_[7] =~ s/-\d+$//o; # remove spotter's ssid - if (Geomag::dup($d,$sfi,$k,$i,$_[6],$_[7])) { + $pc->[7] =~ s/-\d+$//o; # remove spotter's ssid + if (Geomag::dup($d,$sfi,$k,$i,$pc->[6],$pc->[7])) { dbg("PCPROT: Dup WWV Spot ignored\n") if isdbg('chanerr'); return; } # note this only takes the first one it gets - Geomag::update($d, $_[2], $sfi, $k, $i, @_[6..8], $r); + Geomag::update($d, $pc->[2], $sfi, $k, $i, @$pc[6..8], $r); + dbg("WWV: <$pc->[2]>, sfi=$sfi k=$k info=$i '$pc->[6]' $pc->[7]\@$pc->[8] $r route: $origin") if isdbg('progress'); if (defined &Local::wwv) { my $rep; eval { - $rep = Local::wwv($self, $_[1], $_[2], $sfi, $k, $i, @_[6..8], $r); + $rep = Local::wwv($self, $pc->[1], $pc->[2], $sfi, $k, $i, @$pc[6..8], $r); }; return if $rep; } @@ -955,7 +1048,7 @@ sub handle_23 return if $pcno == 27; # broadcast to the eager world - send_wwv_spot($self, $line, $d, $_[2], $sfi, $k, $i, @_[6..8]); + send_wwv_spot($self, $line, $d, $pc->[2], $sfi, $k, $i, @$pc[6..8]); } # set here status @@ -965,7 +1058,9 @@ sub handle_24 my $pcno = shift; my $line = shift; my $origin = shift; - my $call = uc $_[1]; + my $pc = shift; + + my $call = uc $pc->[1]; my ($nref, $uref); $nref = Route::Node::get($call); $uref = Route::User::get($call); @@ -975,12 +1070,12 @@ sub handle_24 return; } - $nref->here($_[2]) if $nref; - $uref->here($_[2]) if $uref; + $nref->here($pc->[2]) if $nref; + $uref->here($pc->[2]) if $uref; my $ref = $nref || $uref; return unless $self->in_filter_route($ref); - $self->route_pc24($origin, $line, $ref, $_[3]); + $self->route_pc24($origin, $line, $ref, $pc->[3]); } # merge request @@ -990,32 +1085,34 @@ sub handle_25 my $pcno = shift; my $line = shift; my $origin = shift; - if ($_[1] ne $main::mycall) { - $self->route($_[1], $line); + my $pc = shift; + + if ($pc->[1] ne $main::mycall) { + $self->route($pc->[1], $line); return; } - if ($_[2] eq $main::mycall) { + if ($pc->[2] eq $main::mycall) { dbg("PCPROT: Trying to merge to myself, ignored") if isdbg('chan'); return; } - Log('DXProt', "Merge request for $_[3] spots and $_[4] WWV from $_[2]"); + Log('DXProt', "Merge request for $pc->[3] spots and $pc->[4] WWV from $pc->[2]"); # spots - if ($_[3] > 0) { - my @in = reverse Spot::search(1, undef, undef, 0, $_[3]); + if ($pc->[3] > 0) { + my @in = reverse Spot::search(1, undef, undef, 0, $pc->[3]); my $in; foreach $in (@in) { - $self->send(pc26(@{$in}[0..4], $_[2])); + $self->send(pc26(@{$in}[0..4], $pc->[2])); } } # wwv - if ($_[4] > 0) { - my @in = reverse Geomag::search(0, $_[4], time, 1); + if ($pc->[4] > 0) { + my @in = reverse Geomag::search(0, $pc->[4], time, 1); my $in; foreach $in (@in) { - $self->send(pc27(@{$in}[0..5], $_[2])); + $self->send(pc27(@{$in}[0..5], $pc->[2])); } } } @@ -1030,12 +1127,14 @@ sub handle_28 my $pcno = shift; my $line = shift; my $origin = shift; - if ($_[1] eq $main::mycall) { + my $pc = shift; + + if ($pc->[1] eq $main::mycall) { no strict 'refs'; my $sub = "DXMsg::handle_$pcno"; - &$sub($self, @_); + &$sub($self, @$pc); } else { - $self->route($_[1], $line) unless $self->is_clx; + $self->route($pc->[1], $line) unless $self->is_clx; } } @@ -1051,10 +1150,12 @@ sub handle_34 my $pcno = shift; my $line = shift; my $origin = shift; + my $pc = shift; + if (eph_dup($line, $eph_pc34_restime)) { return; } else { - $self->process_rcmd($_[1], $_[2], $_[2], $_[3]); + $self->process_rcmd($pc->[1], $pc->[2], $pc->[2], $pc->[3]); } } @@ -1065,8 +1166,10 @@ sub handle_35 my $pcno = shift; my $line = shift; my $origin = shift; - eph_del_regex("^PC35\\^$_[2]\\^$_[1]\\^"); - $self->process_rcmd_reply($_[1], $_[2], $_[1], $_[3]); + my $pc = shift; + + eph_del_regex("^PC35\\^$pc->[2]\\^$pc->[1]\\^"); + $self->process_rcmd_reply($pc->[1], $pc->[2], $pc->[1], $pc->[3]); } sub handle_36 {goto &handle_34} @@ -1078,12 +1181,14 @@ sub handle_37 my $pcno = shift; my $line = shift; my $origin = shift; - if ($_[1] eq $main::mycall) { + my $pc = shift; + + if ($pc->[1] eq $main::mycall) { no strict 'refs'; my $sub = "DXDb::handle_$pcno"; - &$sub($self, @_); + &$sub($self, @$pc); } else { - $self->route($_[1], $line) unless $self->is_clx; + $self->route($pc->[1], $line) unless $self->is_clx; } } @@ -1094,6 +1199,7 @@ sub handle_38 my $pcno = shift; my $line = shift; my $origin = shift; + my $pc = shift; } # incoming disconnect @@ -1103,7 +1209,9 @@ sub handle_39 my $pcno = shift; my $line = shift; my $origin = shift; - if ($_[1] eq $self->{call}) { + my $pc = shift; + + if ($pc->[1] eq $self->{call}) { $self->disconnect(1); } else { dbg("PCPROT: came in on wrong channel") if isdbg('chanerr'); @@ -1119,9 +1227,11 @@ sub handle_41 my $pcno = shift; my $line = shift; my $origin = shift; - my $call = $_[1]; - my $sort = $_[2]; - my $val = $_[3]; + my $pc = shift; + + my $call = $pc->[1]; + my $sort = $pc->[2]; + my $val = $pc->[3]; my $l = "PC41^$call^$sort"; if (eph_dup($l, $eph_info_restime)) { @@ -1190,7 +1300,7 @@ sub handle_41 } # perhaps this IS what we want after all - # $self->route_pc41($ref, $call, $sort, $val, $_[4]); + # $self->route_pc41($ref, $call, $sort, $val, $pc->[4]); } sub handle_42 {goto &handle_28} @@ -1210,15 +1320,16 @@ sub handle_49 my $pcno = shift; my $line = shift; my $origin = shift; + my $pc = shift; if (eph_dup($line)) { return; } - if ($_[1] eq $main::mycall) { - DXMsg::handle_49($self, @_); + if ($pc->[1] eq $main::mycall) { + DXMsg::handle_49($self, @$pc); } else { - $self->route($_[1], $line) unless $self->is_clx; + $self->route($pc->[1], $line) unless $self->is_clx; } } @@ -1229,17 +1340,18 @@ sub handle_50 my $pcno = shift; my $line = shift; my $origin = shift; + my $pc = shift; return if (eph_dup($line)); - my $call = $_[1]; + my $call = $pc->[1]; my $node = Route::Node::get($call); if ($node) { return unless $node->call eq $self->{call}; - $node->usercount($_[2]) unless $node->users; + $node->usercount($pc->[2]) unless $node->users; $node->reset_obs; - $node->PC92C_dxchan($self->call, $_[-1]); + $node->PC92C_dxchan($self->call, $pc->[-1]); # input filter if required # return unless $self->in_filter_route($node); @@ -1247,7 +1359,7 @@ sub handle_50 unless ($self->{isolate}) { DXChannel::broadcast_nodes($line, $self); # send it to everyone but me } -# $self->route_pc50($origin, $line, $node, $_[2], $_[3]) unless eph_dup($line); +# $self->route_pc50($origin, $line, $node, $pc->[2], $pc->[3]) unless eph_dup($line); } } @@ -1258,9 +1370,11 @@ sub handle_51 my $pcno = shift; my $line = shift; my $origin = shift; - my $to = $_[1]; - my $from = $_[2]; - my $flag = $_[3]; + my $pc = shift; + + my $to = $pc->[1]; + my $from = $pc->[2]; + my $flag = $pc->[3]; if ($to eq $main::myalias) { dbg("DXPROT: Ping addressed to \$myalias ($main::myalias), ignored") if isdbg('chan'); @@ -1292,7 +1406,9 @@ sub handle_75 my $pcno = shift; my $line = shift; my $origin = shift; - my $call = $_[1]; + my $pc = shift; + + my $call = $pc->[1]; if ($call ne $main::mycall) { $self->route($call, $line); } @@ -1305,32 +1421,35 @@ sub handle_73 my $pcno = shift; my $line = shift; my $origin = shift; - my $call = $_[1]; + my $pc = shift; + + my $call = $pc->[1]; # do some de-duping - my $d = cltounix($call, sprintf("%02d18Z", $_[2])); - if (($pcno == 23 && $d < $main::systime - $pc23_max_age) || $d > $main::systime + 1500 || $_[2] < 0 || $_[2] > 23) { - dbg("PCPROT: WCY Date ($call $_[2]) out of range") if isdbg('chanerr'); + my $d = cltounix($call, sprintf("%02d18Z", $pc->[2])); + if (($pcno == 23 && $d < $main::systime - $pc23_max_age) || $d > $main::systime + 1500 || $pc->[2] < 0 || $pc->[2] > 23) { + dbg("PCPROT: WCY Date ($call $pc->[2]) out of range") if isdbg('chanerr'); return; } - @_ = map { unpad($_) } @_; + $pc = [ map { unpad($_) } @$pc ]; if (WCY::dup($d)) { dbg("PCPROT: Dup WCY Spot ignored\n") if isdbg('chanerr'); return; } - my $wcy = WCY::update($d, @_[2..12]); + my $wcy = WCY::update($d, @$pc[2..12]); + dbg("WCY: <$pc->[2]> K=$pc->[5] expK=$pc->[6] A=$pc->[4] R=$pc->[7] SFI=$pc->[3] SA=$pc->[8] GMF=$pc->[9] Au=$pc->[10] $pc->[11]\@$pc->[12] route: $origin") if isdbg('progress'); if (defined &Local::wcy) { my $rep; eval { - $rep = Local::wcy($self, @_[1..12]); + $rep = Local::wcy($self, @$pc[1..12]); }; return if $rep; } # broadcast to the eager world - send_wcy_spot($self, $line, $d, @_[2..12]); + send_wcy_spot($self, $line, $d, @$pc[2..12]); } # remote commands (incoming) @@ -1340,7 +1459,9 @@ sub handle_84 my $pcno = shift; my $line = shift; my $origin = shift; - $self->process_rcmd($_[1], $_[2], $_[3], $_[4]); + my $pc = shift; + + $self->process_rcmd($pc->[1], $pc->[2], $pc->[3], $pc->[4]); } # remote command replies @@ -1350,7 +1471,9 @@ sub handle_85 my $pcno = shift; my $line = shift; my $origin = shift; - $self->process_rcmd_reply($_[1], $_[2], $_[3], $_[4]); + my $pc = shift; + + $self->process_rcmd_reply($pc->[1], $pc->[2], $pc->[3], $pc->[4]); } # decode a pc92 call: flag call : version : build @@ -1371,7 +1494,7 @@ sub _decode_pc92_call my $is_extnode = $flag & 2; my $here = $flag & 1; my $ip = $part[3]; - $ip ||= $part[1] if $part[1] && ($part[1] =~ /^(?:\d+\.)+/ || $part[1] =~ /^(?:(?:[abcdef\d]+)?,)+/); + $ip ||= $part[1] if $part[1] && $part[1] !~ /^\d+$/ && ($part[1] =~ /^(?:\d+\.)+/ || $part[1] =~ /^(?:(?:[abcdef\d]+)?,)+/); $ip =~ s/,/:/g if $ip; return ($call, $is_node, $is_extnode, $here, $part[1], $part[2], $ip); } @@ -1450,6 +1573,7 @@ sub _add_thingy delete $things_del{$call}; } } else { + dbgprintring(10) if isdbg('nologchan'); dbg("DXProt::add_thingy: Trying to add parent $call to itself $ncall, ignored"); } } @@ -1664,13 +1788,14 @@ sub handle_92 my $pcno = shift; my $line = shift; my $origin = shift; + my $pc = shift; my (@radd, @rdel); - my $pcall = $_[1]; - my $t = $_[2]; - my $sort = $_[3]; - my $hops = $_[-1]; + my $pcall = $pc->[1]; + my $t = $pc->[2]; + my $sort = $pc->[3]; + my $hops = $pc->[-1]; # this catches loops of A/Ds # if (eph_dup($line, $pc9x_dupe_age)) { @@ -1719,8 +1844,8 @@ sub handle_92 # here is where the consequences of the 'find' command # are dealt with - my $from = $_[4]; - my $target = $_[5]; + my $from = $pc->[4]; + my $target = $pc->[5]; if ($sort eq 'F') { my $flag; @@ -1739,7 +1864,7 @@ sub handle_92 } } elsif ($sort eq 'R') { if (my $dxchan = DXChannel::get($from)) { - handle_pc92_find_reply($dxchan, $pcall, $from, $target, @_[6,7]); + handle_pc92_find_reply($dxchan, $pcall, $from, $target, @$pc[6,7]); } else { my $ref = Route::get($from); if ($ref) { @@ -1762,7 +1887,7 @@ sub handle_92 # remember the last channel we arrived on $parent->PC92C_dxchan($self->{call}, $hops) unless $self->{call} eq $parent->call; - my @ent = _decode_pc92_call($_[4]); + my @ent = _decode_pc92_call($pc->[4]); if (@ent) { my $add; @@ -1790,10 +1915,10 @@ sub handle_92 # here is where all the routes are created and destroyed # cope with missing duplicate node calls in the first slot - my $me = $_[4] || ''; + my $me = $pc->[4] || ''; $me ||= _encode_pc92_call($parent) unless $me ; - my @ent = map {my @a = _decode_pc92_call($_); @a ? \@a : ()} grep {$_ && /^[0-7]/} $me, @_[5 .. $#_]; + my @ent = map {my @a = _decode_pc92_call($_); @a ? \@a : ()} grep {$_ && /^[0-7]/} $me, @$pc[5 .. $#$pc]; if (@ent) { @@ -1935,10 +2060,11 @@ sub handle_93 my $pcno = shift; my $line = shift; my $origin = shift; + my $pc = shift; # $self->{do_pc9x} ||= 1; - my $pcall = $_[1]; # this is now checked earlier + my $pcall = $pc->[1]; # this is now checked earlier # remember that we are converting PC10->PC93 and self will be $main::me if it # comes from us @@ -1947,21 +2073,27 @@ sub handle_93 return; } - my $t = $_[2]; + my $t = $pc->[2]; my $parent = check_pc9x_t($pcall, $t, 93, 1) || return; - my $to = uc $_[3]; - my $from = uc $_[4]; - my $via = uc $_[5]; - my $text = $_[6]; - my $onode = uc $_[7]; - $onode = $pcall if @_ <= 8; + my $to = uc $pc->[3]; + my $from = uc $pc->[4]; + my $via = uc $pc->[5]; + my $text = $pc->[6]; + my $onode = uc $pc->[7]; + $onode = $pcall if @$pc <= 8; # this is catch loops caused by bad software ... if (eph_dup("PC93|$from|$text|$onode", $pc10_dupe_age)) { return; } + if (isdbg('progress')) { + my $vs = $via ne '*' ? " via $via" : ''; + my $s = "ANNTALK: $from\@$onode$vs -> $to '$text' route: $origin"; + dbg($s); + } + # will we allow it at all? if ($censorpc) { my @bad; @@ -2043,15 +2175,16 @@ sub handle_default my $pcno = shift; my $line = shift; my $origin = shift; + my $pc = shift; unless (eph_dup($line)) { if ($pcno >= 90) { - my $pcall = $_[1]; + my $pcall = $pc->[1]; unless (is_callsign($pcall)) { - dbg("PCPROT: invalid callsign string '$_[1]', ignored") if isdbg('chanerr'); + dbg("PCPROT: invalid callsign string '$pc->[1]', ignored") if isdbg('chanerr'); return; } - my $t = $_[2]; + my $t = $pc->[2]; my $parent = check_pc9x_t($pcall, $t, $pcno, 1) || return; $self->broadcast_route_pc9x($pcall, undef, $line, 0); } else { diff --git a/perl/DXProtout.pm b/perl/DXProtout.pm index d829fc37..7629ca16 100644 --- a/perl/DXProtout.pm +++ b/perl/DXProtout.pm @@ -43,7 +43,7 @@ sub pc10 $origin ||= $main::mycall; $text = unpad($text); $text = ' ' unless $text && length $text > 0; - $text =~ s/\^/%5E/g; + $text =~ s/\^/~/g; return "PC10^$from^$user1^$text^*^$user2^$origin^~"; } @@ -54,7 +54,7 @@ sub pc11 my $hops = get_hops(11); my $t = time; $text = ' ' if !$text; - $text =~ s/\^/%5E/g; + $text =~ s/\^/~/g; return sprintf "PC11^%.1f^$dxcall^%s^%s^$text^$mycall^$main::mycall^$hops^~", $freq, cldate($t), ztime($t); } @@ -65,7 +65,7 @@ sub pc61 my $hops = get_hops(61) || get_hops(11); my $t = time; $text = ' ' if !$text; - $text =~ s/\^/%5E/g; + $text =~ s/\^/~/g; return sprintf "PC61^%.1f^$dxcall^%s^%s^$text^$mycall^$main::mycall^$ipaddr^$hops^~", $freq, cldate($t), ztime($t); } @@ -75,7 +75,7 @@ sub pc12 my ($call, $text, $tonode, $sysop, $wx, $origin) = @_; my $hops = get_hops(12); $text ||= ' '; - $text =~ s/\^/%5E/g; + $text =~ s/\^/~/g; $tonode ||= '*'; $sysop ||= ' '; $wx ||= '0'; @@ -130,7 +130,7 @@ sub pc17 sub pc18 { my $flags = shift; - return "PC18^DXSpider Version: $main::version Build: $main::subversion.$main::build Git: $main::gitbranch/$main::gitversion$flags^$DXProt::myprot_version^"; + return "PC18^DXSpider Version: $main::version Build: $main::build Git: $main::gitbranch/$main::gitversion$flags^$DXProt::myprot_version^"; } # @@ -232,7 +232,7 @@ sub pc29 { my ($fromnode, $tonode, $stream, $text) = @_; $text = ' ' unless defined $text && length $text > 0; - $text =~ s/\^/%5E/og; # remove ^ + $text =~ s/\^/~/g; # remove ^ return "PC29^$fromnode^$tonode^$stream^$text^~"; } @@ -474,7 +474,7 @@ sub pc93 my $origin = shift; # this will be present on proxying from PC10 $line = unpad($line); - $line =~ s/\^/\\5E/g; # remove any ^ characters + $line =~ s/\^/~/g; # remove any ^ characters my $s = "PC93^$main::mycall^" . gen_pc9x_t() . "^$to^$from^$via^$line"; $s .= "^$origin" if $origin; $s .= "^H99^"; diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm index abb20a96..be4e2c1d 100644 --- a/perl/DXUtil.pm +++ b/perl/DXUtil.pm @@ -8,10 +8,12 @@ package DXUtil; + use Date::Parse; use IO::File; use File::Copy; use Data::Dumper; +use Time::HiRes qw(gettimeofday tv_interval); use strict; @@ -22,9 +24,10 @@ require Exporter; @EXPORT = qw(atime ztime cldate cldatetime slat slong yesno promptf parray parraypairs phex phash shellregex readfilestr writefilestr filecopy ptimelist - print_all_fields cltounix unpad is_callsign is_long_callsign is_latlong + print_all_fields cltounix unpad is_callsign is_latlong is_qra is_freq is_digits is_pctext is_pcflag insertitem deleteitem - is_prefix dd is_ipaddr $pi $d2r $r2d + is_prefix dd is_ipaddr $pi $d2r $r2d localdata localdata_mv + diffms _diffms _diffus difft parraydifft is_ztime basecall ); @@ -179,7 +182,7 @@ sub ptimelist my $ref = shift; my $out; for (sort keys %$ref) { - $out .= "$_=$ref->{$_}, "; + $out .= "$_=" . atime($ref->{$_}) . ", "; } chop $out; chop $out; @@ -277,6 +280,7 @@ sub shellregex { my $in = shift; $in =~ s{(.)} { $patmap{$1} || "\Q$1" }ge; + $in =~ s|\\/|/|g; return '^' . $in . "\$"; } @@ -379,30 +383,20 @@ sub unpad # check that a field only has callsign characters in it sub is_callsign { - return $_[0] =~ m!^(?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}\d+) # basic prefix - (?:/(?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}\d+))? # / another one (possibly) - [A-Z]{1,4} # callsign letters - (?:/(?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}\d+))? # / another prefix possibly - (?:/[0-9A-Z]{1,2})? # /0-9A-Z+ possibly - (?:-\d{1,2})? # - nn possibly - $!x; -} + return $_[0] =~ m!^ + (?:\d?[A-Z]{1,2}\d{0,2}/)? # out of area prefix / + (?:\d?[A-Z]{1,2}\d{1,5}) # main prefix one (required) - lengthened for special calls + [A-Z]{1,8} # callsign letters (required) + (?:-(?:\d{1,2}))? # - nn possibly (eg G8BPQ-8) + (?:/[0-9A-Z]{1,7})? # / another prefix, callsign or special label (including /MM, /P as well as /EURO or /LGT) possibly + $!x; -# check that a field only has callsign characters in it but has more than the standard 3 callsign letters -sub is_long_callsign -{ - return $_[0] =~ m!^(?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}\d+) # basic prefix - (?:/(?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}\d+))? # / another one (possibly) - [A-Z]{1,5} # callsign letters - (?:/(?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}\d+))? # / another prefix possibly - (?:/[0-9A-Z]{1,2})? # /0-9A-Z+ possibly - (?:-\d{1,2})? # - nn possibly - $!x; + # longest callign allowed is 1X11/1Y11XXXXX-11/XXXXXXX } sub is_prefix { - return $_[0] =~ m!^(?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}\d+)!x # basic prefix + return $_[0] =~ m!^(?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}}\d+)!x # basic prefix } @@ -448,7 +442,13 @@ sub is_latlong # is it an ip address? sub is_ipaddr { - return $_[0] =~ /^\d+\.\d+\.\d+\.\d+$/ || $_[0] =~ /^[0-9a-f:]+$/; + return $_[0] =~ /^\d+\.\d+\.\d+\.\d+$/ || $_[0] =~ /^[0-9a-f:,]+$/; +} + +# is it a zulu time hhmmZ +sub is_ztime +{ + return $_[0] =~ /^(?:(?:2[0-3])|(?:[01][0-9]))[0-5][0-9]Z$/; } # insert an item into a list if it isn't already there returns 1 if there 0 if not @@ -473,3 +473,115 @@ sub deleteitem return $n - @$list; } +# find the correct local_data directory +# basically, if there is a local_data directory with this filename and it is younger than the +# equivalent one in the (system) data directory then return that name rather than the system one +sub localdata +{ + # the expurgated version to make backporting easier + my $ifn = shift; + my $dfn = "$main::data/$ifn"; + return $dfn; +} + +# move a file or a directory from data -> local_data if isn't there already +sub localdata_mv +{ + my $ifn = shift; + if (-e "$main::data/$ifn" ) { + unless (-e "$main::local_data/$ifn") { + move("$main::data/$ifn", "$main::local_data/$ifn") or die "localdata_mv: cannot move $ifn from '$main::data' -> '$main::local_data' $!\n"; + } + } +} + +# measure the time taken for something to happen; use Time::HiRes qw(gettimeofday tv_interval); +sub _diffms +{ + my $ta = shift; + my $tb = shift || [gettimeofday]; + my $a = int($ta->[0] * 1000) + int($ta->[1] / 1000); + my $b = int($tb->[0] * 1000) + int($tb->[1] / 1000); + return $b - $a; +} + +# and in microseconds +sub _diffus +{ + my $ta = shift; + my $tb = shift || [gettimeofday]; + my $a = int($ta->[0] * 1000000) + int($ta->[1]); + my $b = int($tb->[0] * 1000000) + int($tb->[1]); + return $b - $a; +} + +sub diffms +{ + my $call = shift; + my $line = shift; + my $ta = shift; + my $no = shift; + my $tb = shift; + my $msecs = _diffms($ta, $tb); + + $line =~ s|\s+$||; + my $s = "subprocess stats cmd: '$line' $call ${msecs}mS"; + $s .= " $no lines" if $no; + DXDebug::dbg($s); +} + +# expects either an array reference or two times (in the correct order [start, end]) +sub difft +{ + my $b = shift; + my $adds = shift; + + my $t; + if (ref $b eq 'ARRAY') { + $t = $b->[1] - $b->[0]; + } else { + if ($adds && $adds =~ /^\d+$/ && $adds >= $b) { + $t = $adds - $b; + $adds = shift; + } else { + $t = $main::systime - $b; + } + } + return '-(ve)' if $t < 0; + my ($d,$h,$m,$s); + my $out = ''; + $d = int $t / 86400; + $out .= sprintf ("%s${d}d", $adds?' ':'') if $d; + $t -= $d * 86400; + $h = int $t / 3600; + $out .= sprintf ("%s${h}h", $adds?' ':'') if $h; + $t -= $h * 3600; + $m = int $t / 60; + $out .= sprintf ("%s${m}m", $adds?' ':'') if $m; + if ($d == 0 && $adds || $adds == 2) { + $s = int $t % 60; + $out .= sprintf ("%s${s}s", $adds?' ':'') if $s; + $out ||= sprintf ("%s0s", $adds?' ':''); + } + $out = '0s' unless length $out; + return $out; +} + +# print an array ref of difft refs +sub parraydifft +{ + my $r = shift; + my $out = ''; + for (@$r) { + my $s = $_->[2] ? "($_->[2])" : ''; + $out .= sprintf "%s=%s$s, ", atime($_->[0]), difft($_->[0], $_->[1]); + } + $out =~ s/,\s*$//; + return $out; +} + +sub basecall +{ + my ($r) = $_[0] =~ m|^(?:[\w\d]+/)?([\w\d]+).*$|; + return $r; +} diff --git a/perl/Version.pm b/perl/Version.pm index 314b78a3..c18e5c66 100644 --- a/perl/Version.pm +++ b/perl/Version.pm @@ -11,7 +11,7 @@ use vars qw($version $subversion $build $gitversion); $version = '1.55'; $subversion = '0'; -$build = '166'; -$gitversion = '4868adf[i]'; +$build = '227'; +$gitversion = 'd38c9fb5[i]'; 1; diff --git a/perl/cluster.pl b/perl/cluster.pl index 3c02e038..69418a3b 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -409,7 +409,7 @@ if (DXSql::init($dsn)) { if (!$@ && $desc) { my ($v, $s, $b, $g) = $desc =~ /^([\d.]+)(?:\.(\d+))?-(\d+)-g([0-9a-f]+)/; $version = $v; - my $subversion = $s || 0; + $subversion = $s || 0; $build = $b || 0; $gitversion = "$g\[r]"; } diff --git a/perl/issue.pl b/perl/issue.pl index 802c12e6..923725e6 100755 --- a/perl/issue.pl +++ b/perl/issue.pl @@ -19,7 +19,7 @@ use strict; use vars qw($root); my $fn = "$root/perl/Version.pm"; my $desc = `git describe --long`; -my ($v, $s, $b, $g) = $desc =~ /^([\d.]+)(?:\.(\d+))?-(\d+)-g([0-9a-f]+)/; +my ($v, $s, $b, $g) = $desc =~ /^([\d\.]+)(?:\.(\d+))?-(\d+)-g([0-9a-f]+)/; $s ||= '0'; # account for missing subversion $b++; # to account for the commit that is about to happen -- 2.43.0