From dca951f539a50c396d7a94ad9f513a19892d54ad Mon Sep 17 00:00:00 2001 From: minima Date: Mon, 7 Mar 2005 22:52:23 +0000 Subject: [PATCH] make the ping stuff not crash immediately --- cmd/show/425.pl | 2 +- perl/DXDupe.pm | 2 +- perl/DXUtil.pm | 6 ++++ perl/Spot.pm | 12 ++++--- perl/Thingy.pm | 28 ++++++++++++++-- perl/Thingy/Ping.pm | 80 ++++++++++++++++----------------------------- perl/Thingy/Rt.pm | 2 +- 7 files changed, 69 insertions(+), 63 deletions(-) diff --git a/cmd/show/425.pl b/cmd/show/425.pl index 044950d0..a8558da9 100644 --- a/cmd/show/425.pl +++ b/cmd/show/425.pl @@ -34,7 +34,7 @@ foreach $l (@list) { push @out, $self->msg('e18', 'Open(425.org)'); } else { my $s = "GET $url/modules.php?name=425dxn&op=spider&query=$l HTTP/1.0\n" - ."User-Agent:DxSpider;$main::version;$main::build;$^O;$main::mycall;$call;$l)\n\n"; + ."User-Agent:DxSpider;$main::version;$main::build;$^O;$main::mycall;$call;$l\n\n"; dbg($s) if isdbg('425'); $t->print($s); Log('call', "$call: show/425 \U$l"); diff --git a/perl/DXDupe.pm b/perl/DXDupe.pm index 1a0eb14c..a5db5499 100644 --- a/perl/DXDupe.pm +++ b/perl/DXDupe.pm @@ -101,7 +101,7 @@ sub listdups my @out; for (sort { $d{$a} <=> $d{$b} } grep { m{$regex}i } keys %d) { my ($dum, $key) = unpack "a1a*", $_; - push @out, "$key = " . cldatetime($d{$_} - $dupage); + push @out, "$key = " . cldatetime($d{$_} - $dupage) . " expires " . cldatetime($d{$_}); } return @out; } diff --git a/perl/DXUtil.pm b/perl/DXUtil.pm index 9f411812..468f225f 100644 --- a/perl/DXUtil.pm +++ b/perl/DXUtil.pm @@ -30,6 +30,7 @@ require Exporter; filecopy ptimelist print_all_fields cltounix unpad is_callsign is_latlong is_qra is_freq is_digits is_pctext is_pcflag insertitem deleteitem + is_prefix ); @@ -363,6 +364,11 @@ sub is_callsign $!x; } +sub is_prefix +{ + return $_[0] =~ m!^(?:[A-Z]{1,2}\d+ | \d[A-Z]{1,2}\d+)!x # basic prefix +} + # check that a PC protocol field is valid text sub is_pctext { diff --git a/perl/Spot.pm b/perl/Spot.pm index 53f98fa6..3bd74c4f 100644 --- a/perl/Spot.pm +++ b/perl/Spot.pm @@ -368,13 +368,15 @@ sub dup chomp $text; $text =~ s/\%([0-9A-F][0-9A-F])/chr(hex($1))/eg; - $text = unpad($text); - $text = substr($text, 0, $duplth) if length $text > $duplth; + $text = uc unpad($text); + my ($prefix) = $text =~ /\b(\w{1,4})$/; + $text =~ s/\b\w{1,4}$// if $prefix && is_prefix($prefix); + $text = substr($text, 0, $duplth) if length $text > $duplth; $text = pack("C*", map {$_ & 127} unpack("C*", $text)); - $text =~ s/[^a-zA-Z0-9]//g; - my $ldupkey = "X$freq|$call|$by|" . uc $text; + $text =~ s/[^\w]//g; + my $ldupkey = "X$freq|$call|$by|$text"; my $t = DXDupe::find($ldupkey); - return 1 if $t && $t - $main::systime > 0; + return 1 if $t && $t - $main::systime > 0; DXDupe::add($ldupkey, $main::systime+$dupage); # my $sdupkey = "X$freq|$call|$by"; # $t = DXDupe::find($sdupkey); diff --git a/perl/Thingy.pm b/perl/Thingy.pm index 6ab36080..0ab70dcf 100644 --- a/perl/Thingy.pm +++ b/perl/Thingy.pm @@ -36,6 +36,8 @@ my $lastmin = time; use DXChannel; use DXDebug; +use DXUtil; + # we expect all thingies to be subclassed sub new @@ -95,13 +97,33 @@ sub send } } -# broadcast to all except @_ +# +# This is the main routing engine for the new protocol. Broadcast is a slight +# misnomer, because if it thinks it can route it down one or interfaces, it will. +# +# It handles anything it recognises as a callsign, sees if it can find it in a +# routing table, and if it does, then routes the message. +# +# If it can't then it will broadcast it. +# sub broadcast { my $thing = shift; dbg("Thingy::broadcast: " . $thing->ascii) if isdbg('thing'); - foreach my $dxchan (DXChannel::get_all()) { + my @dxchan; + my $to ||= $thing->{touser}; + $to ||= $thing->{group}; + if ($to && is_callsign($to) && (my $ref = Route::get($to))) { + dbg("Thingy::broadcast: routing for $to") if isdbg('thing'); + @dxchan = $ref->alldxchan; + } else { + @dxchan = DXChannel::get_all(); + } + + dbg("Thingy::broadcast: offered " . join(',', map {$_->call} @dxchan)) if isdbg('thing'); + + foreach my $dxchan (@dxchan) { next if $dxchan == $main::me; next if grep $dxchan == $_, @_; next if $dxchan->{call} eq $thing->{origin}; @@ -222,7 +244,7 @@ sub new_reply } elsif (DXChannel::get($thing->{group})) { $out = $thing->new(user => $thing->{group}); $out->{touser} = $thing->{user} if $thing->{user}; - } elsif ($thing->{touser} && DXChannel->{$thing->{touser}}) { + } elsif ($thing->{touser} && DXChannel::get($thing->{touser})) { $out = $thing->new(user => $thing->{touser}); $out->{group} = $thing->{group}; } diff --git a/perl/Thingy/Ping.pm b/perl/Thingy/Ping.pm index 09d0e592..edcd8fe7 100644 --- a/perl/Thingy/Ping.pm +++ b/perl/Thingy/Ping.pm @@ -19,8 +19,10 @@ use DXDebug; use DXUtil; use Thingy; use Spot; +use Time::HiRes qw(gettimeofday tv_interval); -use vars qw(@ISA @ping); + +use vars qw(@ISA %ping); @ISA = qw(Thingy); my $id; @@ -29,7 +31,7 @@ sub gen_Aranea { my $thing = shift; unless ($thing->{Aranea}) { - $thing->{Aranea} = Aranea::genmsg($thing); + $thing->{Aranea} = Aranea::genmsg($thing, qw(id)); } return $thing->{Aranea}; } @@ -59,7 +61,7 @@ sub gen_DXCommandmode sub from_DXProt { - my $thing = ref $_[0] ? shift : $thing->SUPER::new(); + my $thing = ref $_[0] ? shift : $_[0]->SUPER::new(); while (@_) { my $k = shift; @@ -76,37 +78,27 @@ sub handle # is it for us? if ($thing->{group} eq $main::mycall) { if ($thing->{out} == 1) { - my $repthing; - if ($thing->{touser}) { - if (my $dxchan = DXChannel::get($thing->{touser})) { - if ($dxchan->is_node) { - $thing->send($dxchan); - } else { - $repthing = Thingy::Ping->new_reply($thing); - } - } - } else { - $repthing = Thingy::Ping->new_reply($thing); - } + my $repthing = $thing->new_reply; + $repthing->{out} = 0; + $repthing->{id} = $thing->{id}; $repthing->send($dxchan) if $repthing; } else { # it's a reply, look in the ping list for this one - my $ref = $pings{$from}; + my $ref = $ping{$thing->{id}} || $thing->find; if ($ref) { - my $tochan = DXChannel::get($from); - while (@$ref) { - my $r = shift @$ref; - my $dxchan = DXChannel::get($r->{call}); - next unless $dxchan; - my $t = tv_interval($r->{t}, [ gettimeofday ]); - if ($dxchan->is_user) { + my $t = tv_interval($thing->{t}, [ gettimeofday ]); + if (my $dxc = DXChannel::get($thing->{user} || $thing->{origin})) { + + my $tochan = DXChannel::get($thing->{touser} || $thing->{group}); + + if ($dxc->is_user) { my $s = sprintf "%.2f", $t; my $ave = sprintf "%.2f", $tochan ? ($tochan->{pingave} || $t) : $t; - $dxchan->send($dxchan->msg('pingi', $from, $s, $ave)) - } elsif ($dxchan->is_node) { - if ($tochan) { - my $nopings = $tochan->user->nopings || $obscount; + $dxc->send($dxc->msg('pingi', ($thing->{touser} || $thing->{group}), $s, $ave)) + } elsif ($dxc->is_node) { + if ($tochan ) { + my $nopings = $tochan->user->nopings || $DXProt::obscount; push @{$tochan->{pingtime}}, $t; shift @{$tochan->{pingtime}} if @{$tochan->{pingtime}} > 6; @@ -122,13 +114,6 @@ sub handle $tochan->{pingave} = $tochan->{pingave} + (($t - $tochan->{pingave}) / 6); } $tochan->{nopings} = $nopings; # pump up the timer - if (my $ivp = Investigate::get($from, $origin)) { - $ivp->handle_ping; - } - } elsif (my $rref = Route::Node::get($r->{call})) { - if (my $ivp = Investigate::get($from, $origin)) { - $ivp->handle_ping; - } } } } @@ -156,10 +141,10 @@ sub remember $thing->{id} = ++$id; my $u = DXUser->get_current($thing->{to}); if ($u) { - $u->lastping(($thing->{group} || $thing->{user}), $main::systime); + $u->lastping(($thing->{user} || $thing->{group}), $main::systime); $u->put; } - push @ping, $thing; + $ping{$id} = $thing; } # remove any pings outstanding that we have remembered for this @@ -169,30 +154,21 @@ sub forget my $call = shift; my $count = 0; my @out; - for (@ping) { - if ($thing->{user} eq $call) { + foreach my $thing (values %ping) { + if (($thing->{user} || $thing->{group}) eq $call) { $count++; - } else { - push @out, $_; + delete $ping{$thing->{id}}; } } - @ping = @out; return $count; } sub find { - my $from = shift; - my $to = shift; - my $via = shift; - - for (@ping) { - if ($_->{user} eq $from && $_->{to} eq $to) { - if ($via) { - return $_ if $_->{group} eq $via; - } else { - return $_; - } + my $call = shift; + foreach my $thing (values %ping) { + if (($thing->{user} || $thing->{origin}) eq $call) { + return $thing; } } return undef; diff --git a/perl/Thingy/Rt.pm b/perl/Thingy/Rt.pm index 685ef0c4..13756c22 100644 --- a/perl/Thingy/Rt.pm +++ b/perl/Thingy/Rt.pm @@ -191,7 +191,7 @@ sub _add_user my $flag = shift; my @out = $node->add_user($user, $flag); - my $ur = _upd_user_rec($user, $node); + my $ur = _upd_user_rec($user, $node->{call}); $ur->put; return @out; } -- 2.43.0