From 8178d787d7cc8040fa8958197582bba5c80e6f59 Mon Sep 17 00:00:00 2001 From: minima Date: Sun, 13 Oct 2002 19:35:41 +0000 Subject: [PATCH] added the state filtering stuff tried to speed up the AUTOLOADING tried to fix the near dupe check again --- Changes | 22 ++++++++++ cmd/Commands_en.hlp | 39 ++++++++++++++++- cmd/load/usdb.pl | 1 + cmd/show/prefix.pl | 3 ++ perl/AnnTalk.pm | 2 + perl/Bands.pm | 11 +++-- perl/DXChannel.pm | 11 +++-- perl/DXDb.pm | 11 +++-- perl/DXMsg.pm | 11 +++-- perl/DXProt.pm | 9 ++-- perl/DXUser.pm | 19 ++++---- perl/Filter.pm | 5 +++ perl/Prefix.pm | 103 +++++++++++++++++++++++++++++++------------- perl/Prot.pm | 11 +++-- perl/Route.pm | 22 ++++++++-- perl/Spot.pm | 30 +++++++++---- perl/USDB.pm | 8 +++- perl/cluster.pl | 1 + 18 files changed, 242 insertions(+), 77 deletions(-) diff --git a/Changes b/Changes index e6cab461..193f9cc0 100644 --- a/Changes +++ b/Changes @@ -1,3 +1,25 @@ +13Oct02======================================================================= +1. A large change has occurred. There is now some (optional) US state recog- +nition. This is in its early stages but appears to work for me. You will need +to download the database at http://www.dxcluster.org/download/usdbraw, save it +in /spider/data and the run /spider/perl/create_usdb.pl. BE WARNED this will +take several minutes. You can do this while the node is running. There is a +planned method of keeping the US DB up to date with smaller (ie < 5Mb) patch +files once a week but you will have to wait a bit for the code to bed down +first. You can filter on routes, spots and announces using 'call_state' or +'by_state' and a comma separated list of state codes. The HELP has been +updated (which may help...). + +Once you have run the create_usdb.pl you will need to restart. + +If you don't need this, then don't run create_usdb.pl it will simply be +a waste of time. The run-time version is 24Mb and has 840,000 odd entries +in it. This does not replace or supplant sh/qrz (sorry Charlie [who put me +up to this]). + +2. There are a number of other niff-naff changes which I hope will improve +rather than hinder your user experience (including check forward as well as +back for those speedy clocked dupes mentioned below). 12Oct02======================================================================= 1. attempt to improve the "check back for 5 minutes to see if this spot is the same as a previous one but for the time spotted" dupe check. diff --git a/cmd/Commands_en.hlp b/cmd/Commands_en.hlp index 4058c8c7..eca6dacb 100644 --- a/cmd/Commands_en.hlp +++ b/cmd/Commands_en.hlp @@ -32,9 +32,11 @@ You can use any of the following things in this line:- origin_dxcc eg: 61,62 (from eg: sh/pre G) origin_itu or: G,GM,GW origin_zone + origin_state eg: VA,NH,RI,NH by_dxcc by_itu by_zone + by_state channel wx 1 filter WX announces dest eg: 6MUK,WDX (distros) @@ -47,6 +49,10 @@ some examples:- or acc/ann by G,M,2 +for american states + + acc/ann by_state va,nh,ri,nh + You can use the tag 'all' to accept everything eg: acc/ann all @@ -74,16 +80,25 @@ You can use any of the following things in this line:- call_dxcc eg: 61,62 (from eg: sh/pre G) call_itu or: G,GM,GW call_zone + call_state eg: VA,NH,RI,NH origin really the interface it came in on origin_dxcc eg: 61,62 (from eg: sh/pre G) origin_itu or: G,GM,GW origin_zone + origin_state eg: VA,NH,RI,NH some examples:- acc/route gb7djk call_dxcc 61,38 (send only UK+EIRE nodes) acc/route gb7djk call gb7djk (equiv to SET/ISOLATE) +you can now use 'by' as a synonym for 'call' so: + + by = call + by_dxcc = call_dxcc + +and so on + You can use the tag 'all' to accept everything eg: acc/route all @@ -106,12 +121,16 @@ You can use any of the following things in this line:- call_dxcc eg: 61,62 (from eg: sh/pre G) call_itu or: G,GM,GW call_zone + call_state eg: VA,NH,RI,ME by_dxcc by_itu by_zone + by_state eg: VA,NH,RI,ME origin channel +'call' means the callsign that has spotted 'by' whoever. + For frequencies, you can use any of the band names defined in SHOW/BANDS and you can use a subband name like: cw, rtty, data, ssb - thus: hf/ssb. You can also just have a simple range like: 0/30000 - @@ -127,6 +146,10 @@ You can use the tag 'all' to accept everything, eg: acc/spot 3 all +for US states + + acc/spots by_state VA,NH,RI,MA,ME + but this probably for advanced users... @@ -598,7 +621,7 @@ you have specified is taken (ie reject means ignore it and accept means gimme it). The important thing to remember is that if you specify a 'reject' -filter (all the lines in it say 'reject/spots' (for instance) then if +filter (all the lines in it say 'reject/spots' (for instance)) then if a spot comes in that doesn't match any of the lines then you will get it BUT if you specify an 'accept' filter then any spots that don't match are dumped. For example if I have a one line accept filter:- @@ -625,6 +648,10 @@ you are confortable with the way it works. Yes, you can mix them don't try this at home until you can analyse the results that you get without ringing up the sysop for help. +Another useful addition now is filtering by US state + + accept/spots by_state VA,NH,RI,ME + You can arrange your filter lines into logical units, either for your own understanding or simply convenience. I have one set frequently:- @@ -954,9 +981,11 @@ You can use any of the following things in this line:- origin_dxcc eg: 61,62 (from eg: sh/pre G) origin_itu or: G,GM,GW origin_zone + origin_state eg: VA,NH,RI,ME by_dxcc by_itu by_zone + by_state eg: VA,NH,RI,ME channel wx 1 filter WX announces dest eg: 6MUK,WDX (distros) @@ -996,12 +1025,16 @@ You can use any of the following things in this line:- call_dxcc eg: 61,62 (from eg: sh/pre G) call_itu or: G,GM,GW call_zone + call_state eg: VA,NH,RI,ME by_dxcc by_itu by_zone + by_state eg: VA,NH,RI,ME origin channel +'call' means the callsign that has spotted 'by' whoever. + For frequencies, you can use any of the band names defined in SHOW/BANDS and you can use a subband name like: cw, rtty, data, ssb - thus: hf/ssb. You can also just have a simple range like: 0/30000 - @@ -1032,10 +1065,12 @@ You can use any of the following things in this line:- call_dxcc eg: 61,62 (from eg: sh/pre G) call_itu or: G,GM,GW call_zone + call_state eg: VA,NH,RI,ME origin really the interface it came in on origin_dxcc eg: 61,62 (from eg: sh/pre G) origin_itu or: G,GM,GW origin_zone + origin_state eg: VA,NH,RI,ME some examples:- @@ -1045,6 +1080,8 @@ You can use the tag 'all' to reject everything eg: rej/route all (equiv to [very] restricted mode) +as with ACCEPT/ROUTE 'by' is now a synonym for 'call'. + === 8^REJECT/SPOTS [input] [0-9] ^Spot filter sysop version This version allows a sysop to set a filter for a callsign as well as the default for nodes and users eg:- diff --git a/cmd/load/usdb.pl b/cmd/load/usdb.pl index 7ed76067..bd45547d 100644 --- a/cmd/load/usdb.pl +++ b/cmd/load/usdb.pl @@ -18,5 +18,6 @@ return (1, $self->msg('e5')) if $self->priv < 9; return (1, $self->msg('e3', "load/usdb", $line)) if $line && !-r $line; $line = "$main::data/usdbraw" unless $line; push @out, (USDB::load($line)); +USDB::init() unless @OUT; @out = ($self->msg('ok')) unless @out; return (1, @out); diff --git a/cmd/show/prefix.pl b/cmd/show/prefix.pl index 200a4f1e..df0f192c 100644 --- a/cmd/show/prefix.pl +++ b/cmd/show/prefix.pl @@ -20,6 +20,9 @@ foreach $l (@list) { push @out, sprintf "%s DXCC: %d ITU: %d CQ: %d LL: %s %s (%s, %s)", uc $l, $a->dxcc, $a->itu, $a->cq, slat($a->lat), slong($a->long), $pre, $a->name; $l = " " x length $l; } + if ($ans[0]->state) { + push @out, sprintf "%s City: %s State: %s", $l, join (' ', map {ucfirst} split(/\s+/, lc $ans[0]->city)), $ans[0]->state; + } } return (1, @out); diff --git a/perl/AnnTalk.pm b/perl/AnnTalk.pm index 58c2a439..30f8964c 100644 --- a/perl/AnnTalk.pm +++ b/perl/AnnTalk.pm @@ -34,6 +34,8 @@ $filterdef = bless ([ ['origin_dxcc', 'nc', 10], ['origin_itu', 'ni', 11], ['origin_zone', 'nz', 12], + ['by_state', 'nz', 13], + ['origin_state', 'nz', 14], ], 'Filter::Cmd'); use vars qw($VERSION $BRANCH); diff --git a/perl/Bands.pm b/perl/Bands.pm index 069c8ccd..65849c9a 100644 --- a/perl/Bands.pm +++ b/perl/Bands.pm @@ -137,18 +137,21 @@ sub field_prompt return $valid{$ele}; } -no strict; +#no strict; sub AUTOLOAD { + no strict; my $self = shift; my $name = $AUTOLOAD; return if $name =~ /::DESTROY$/; - $name =~ s/.*:://o; + $name =~ s/^.*:://o; # this clever line of code creates a subroutine which takes over from autoload # from OO Perl - Conway - *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ; - @_ ? $self->{$name} = shift : $self->{$name} ; + *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}}; + &$AUTOLOAD($self, @_); +# *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ; +# @_ ? $self->{$name} = shift : $self->{$name} ; } 1; diff --git a/perl/DXChannel.pm b/perl/DXChannel.pm index e6e0d1b4..372599af 100644 --- a/perl/DXChannel.pm +++ b/perl/DXChannel.pm @@ -622,20 +622,23 @@ sub broadcast_list } -no strict; +#no strict; sub AUTOLOAD { my $self = shift; + no strict; my $name = $AUTOLOAD; return if $name =~ /::DESTROY$/; - $name =~ s/.*:://o; + $name =~ s/^.*:://o; confess "Non-existant field '$AUTOLOAD'" if !$valid{$name}; # this clever line of code creates a subroutine which takes over from autoload # from OO Perl - Conway - *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ; - @_ ? $self->{$name} = shift : $self->{$name} ; + *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}}; + &$AUTOLOAD($self, @_); +# *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ; +# @_ ? $self->{$name} = shift : $self->{$name} ; } diff --git a/perl/DXDb.pm b/perl/DXDb.pm index 03e84e0c..b7a88671 100644 --- a/perl/DXDb.pm +++ b/perl/DXDb.pm @@ -345,19 +345,22 @@ sub field_prompt return $valid{$ele}; } -no strict; +#no strict; sub AUTOLOAD { my $self = shift; + no strict; my $name = $AUTOLOAD; return if $name =~ /::DESTROY$/; - $name =~ s/.*:://o; + $name =~ s/^.*:://o; confess "Non-existant field '$AUTOLOAD'" if !$valid{$name}; # this clever line of code creates a subroutine which takes over from autoload # from OO Perl - Conway - *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ; - @_ ? $self->{$name} = shift : $self->{$name} ; + *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}}; + &$AUTOLOAD($self, @_); +# *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ; +# @_ ? $self->{$name} = shift : $self->{$name} ; } 1; diff --git a/perl/DXMsg.pm b/perl/DXMsg.pm index 3ea32115..10d1e4dc 100644 --- a/perl/DXMsg.pm +++ b/perl/DXMsg.pm @@ -1506,19 +1506,22 @@ sub import_one return @out; } -no strict; +#no strict; sub AUTOLOAD { my $self = shift; + no strict; my $name = $AUTOLOAD; return if $name =~ /::DESTROY$/; - $name =~ s/.*:://o; + $name =~ s/^.*:://o; confess "Non-existant field '$AUTOLOAD'" if !$valid{$name}; # this clever line of code creates a subroutine which takes over from autoload # from OO Perl - Conway - *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ; - @_ ? $self->{$name} = shift : $self->{$name} ; + *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}}; + &$AUTOLOAD($self, @_); +# *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ; +# @_ ? $self->{$name} = shift : $self->{$name} ; } 1; diff --git a/perl/DXProt.pm b/perl/DXProt.pm index 9a4f3673..2bfb9e5e 100644 --- a/perl/DXProt.pm +++ b/perl/DXProt.pm @@ -1498,24 +1498,27 @@ sub send_announce # obtain country codes etc my ($ann_dxcc, $ann_itu, $ann_cq, $org_dxcc, $org_itu, $org_cq) = (0..0); + my ($ann_state, $org_state) = ("", ""); my @dxcc = Prefix::extract($_[0]); if (@dxcc > 0) { $ann_dxcc = $dxcc[1]->dxcc; $ann_itu = $dxcc[1]->itu; $ann_cq = $dxcc[1]->cq; + $ann_state = $dxcc[1]->state; } @dxcc = Prefix::extract($_[4]); if (@dxcc > 0) { $org_dxcc = $dxcc[1]->dxcc; $org_itu = $dxcc[1]->itu; $org_cq = $dxcc[1]->cq; + $org_state = $dxcc[1]->state; } if ($self->{inannfilter}) { my ($filter, $hops) = $self->{inannfilter}->it(@_, $self->{call}, $ann_dxcc, $ann_itu, $ann_cq, - $org_dxcc, $org_itu, $org_cq); + $org_dxcc, $org_itu, $org_cq, $ann_state, $org_state); unless ($filter) { dbg("PCPROT: Rejected by input announce filter") if isdbg('chanerr'); return; @@ -1875,7 +1878,7 @@ sub send_route if (!$self->{isolate} && $self->{routefilter}) { $filter = undef; if ($r) { - ($filter, $hops) = $self->{routefilter}->it($self->{call}, $self->{dxcc}, $self->{itu}, $self->{cq}, $r->call, $r->dxcc, $r->itu, $r->cq); + ($filter, $hops) = $self->{routefilter}->it($self->{call}, $self->{dxcc}, $self->{itu}, $self->{cq}, $r->call, $r->dxcc, $r->itu, $r->cq, $self->{state}, $r->{state}); if ($filter) { push @rin, $r; } else { @@ -1976,7 +1979,7 @@ sub in_filter_route my ($filter, $hops) = (1, 1); if ($self->{inroutefilter}) { - ($filter, $hops) = $self->{inroutefilter}->it($self->{call}, $self->{dxcc}, $self->{itu}, $self->{cq}, $r->call, $r->dxcc, $r->itu, $r->cq); + ($filter, $hops) = $self->{inroutefilter}->it($self->{call}, $self->{dxcc}, $self->{itu}, $self->{cq}, $r->call, $r->dxcc, $r->itu, $r->cq, $self->state, $r->state); dbg("PCPROT: $self->{call}/" . $r->call . ' rejected by in_filter_route') if !$filter && isdbg('chanerr'); } return $filter; diff --git a/perl/DXUser.pm b/perl/DXUser.pm index 6b85afb3..afc70cb0 100644 --- a/perl/DXUser.pm +++ b/perl/DXUser.pm @@ -86,26 +86,29 @@ $lrusize = 2000; build => '1,Build', ); -no strict; +#no strict; sub AUTOLOAD { my $self = shift; + no strict; my $name = $AUTOLOAD; return if $name =~ /::DESTROY$/; - $name =~ s/.*:://o; + $name =~ s/^.*:://o; confess "Non-existant field '$AUTOLOAD'" if !$valid{$name}; # this clever line of code creates a subroutine which takes over from autoload # from OO Perl - Conway - *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ; - if (@_) { - $self->{$name} = shift; - } - return $self->{$name}; + *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}}; + &$AUTOLOAD($self, @_); +# *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ; +# if (@_) { +# $self->{$name} = shift; +# } +# return $self->{$name}; } -use strict; +#use strict; # # initialise the system diff --git a/perl/Filter.pm b/perl/Filter.pm index 66c3ff7a..0ca71917 100644 --- a/perl/Filter.pm +++ b/perl/Filter.pm @@ -494,6 +494,11 @@ sub parse my @pre = Prefix::to_ciz($cmd, @val); return ('numpre', $dxchan->msg('e27', $_)) unless @pre; $s .= "(" . join(' || ', map {"\$r->[$fref->[2]]==$_"} @pre) . ")"; + } elsif ($fref->[1] =~ /^ns$/ ) { # for DXCC, ITU, CQ Zone + my $cmd = $fref->[1]; + my @pre = Prefix::to_ciz($cmd, @val); + return ('numpre', $dxchan->msg('e27', $_)) unless @pre; + $s .= "(" . "!\$USDB::present || grep \$r->[$fref->[2]] eq \$_, qw(" . join(' ' ,map {uc} @pre) . "))"; } elsif ($fref->[1] eq 'r') { my @t; for (@val) { diff --git a/perl/Prefix.pm b/perl/Prefix.pm index 246dbb65..5733ff02 100644 --- a/perl/Prefix.pm +++ b/perl/Prefix.pm @@ -14,6 +14,7 @@ use DB_File; use Data::Dumper; use DXDebug; use DXUtil; +use USDB; use LRU; use strict; @@ -129,7 +130,32 @@ sub next return () if $db->seq($gotkey, $ref, R_NEXT); return () if $key ne substr $gotkey, 0, length $key; - return ($gotkey, map { $prefix_loc{$_} } split ',', $ref); + return ($gotkey, map { $prefix_loc{$_} } split ',', $ref); +} + +# +# put the key LRU incluing the city state info +# + +sub lru_put +{ + my ($call, $ref) = @_; + my @s = USDB::get($call); + + if (@s) { + # this is deep magic, because this is a reference to static data, it + # must be copied. + my $h = { %{$ref->[1]} }; + bless $h, ref $ref->[1]; + $h->{city} = $s[0]; + $h->{state} = $s[1]; + $ref->[1] = $h; + } else { + $ref->[1]->{city} = $ref->[1]->{state} = "" unless exists $ref->[1]->{state}; + } + + dbg("Prefix::lru_put $call -> ($ref->[1]->{city}, $ref->[1]->{state})") if isdbg('prefix'); + $lru->put($call, $ref); } # @@ -153,7 +179,7 @@ sub matchprefix my $percent = sprintf "%.1f", $hits * 100 / $misses; dbg("Partial Prefix Cache Hit: $s Hits: $hits/$misses of $matchtotal = $percent\%"); } - $lru->put($_, $p) for @partials; + lru_put($_, $p) for @partials; return @$p; } else { $misses++; @@ -164,7 +190,6 @@ sub matchprefix dbg("Partial prefix: $pref $s $part" ); } if (@out && $out[0] eq $s) { - $lru->put($_, \@out) for @partials; return @out; } } @@ -205,10 +230,21 @@ LM: foreach $call (split /,/, $calls) { push @out, @$p; next; } else { - @nout = get($call); + + # is it in the USDB, force a matchprefix to match? + my @s = USDB::get($call); + if (@s) { + @nout = get($call); + @nout = matchprefix($call) unless @nout; + $nout[0] = $call if @nout; + } else { + @nout = get($call); + } + + # now store it if (@nout && $nout[0] eq $call) { $misses++; - $lru->put($call, \@nout); + lru_put($call, \@nout); dbg("got exact prefix: $nout[0]") if isdbg('prefix'); push @out, @nout; next; @@ -229,7 +265,7 @@ LM: foreach $call (split /,/, $calls) { if (@nout && $nout[0] eq $s) { dbg("got exact multipart prefix: $call $s") if isdbg('prefix'); $misses++; - $lru->put($call, \@nout); + lru_put($call, \@nout); push @out, @nout; next; } @@ -249,7 +285,7 @@ LM: foreach $call (split /,/, $calls) { if (@try && $try[0] eq $s) { dbg("got 3 part prefix: $call $s") if isdbg('prefix'); $misses++; - $lru->put($call, \@try); + lru_put($call, \@try); push @out, @try; next; } @@ -272,7 +308,7 @@ LM: foreach $call (split /,/, $calls) { if (@try && $try[0] eq $s) { dbg("got 2 part prefix: $call $s") if isdbg('prefix'); $misses++; - $lru->put($call, \@try); + lru_put($call, \@try); push @out, @try; next; } @@ -288,7 +324,7 @@ LM: foreach $call (split /,/, $calls) { if (@nout) { dbg("got prefix: $call = $nout[0]") if isdbg('prefix'); $misses++; - $lru->put($call, \@nout); + lru_put($call, \@nout); push @out, @nout; next; } @@ -333,16 +369,16 @@ L1: for ($n = 0; $n < @parts; $n++) { } if (@try && $try eq $try[0]) { $misses++; - $lru->put($call, \@try); + lru_put($call, \@try); push @out, @try; } else { $misses++; - $lru->put($call, \@nout); + lru_put($call, \@nout); push @out, @nout; } } else { $misses++; - $lru->put($call, \@nout); + lru_put($call, \@nout); push @out, @nout; } next LM; @@ -352,7 +388,7 @@ L1: for ($n = 0; $n < @parts; $n++) { # we are a pirate! @nout = matchprefix('Q'); $misses++; - $lru->put($call, \@nout); + lru_put($call, \@nout); push @out, @nout; } @@ -369,6 +405,7 @@ L1: for ($n = 0; $n < @parts; $n++) { # nc = dxcc # ni = itu # nz = zone +# ns = state # sub to_ciz @@ -377,18 +414,24 @@ sub to_ciz my @out; foreach my $v (@_) { - if ($v =~ /^\d+$/) { + if ($cmd ne 'ns' && $v =~ /^\d+$/) { push @out, $v unless grep $_ eq $v, @out; } else { - my @pre = Prefix::extract($v); - return () unless @pre; - shift @pre; - foreach my $p (@pre) { - my $n = $p->dxcc if $cmd eq 'nc' ; - $n = $p->itu if $cmd eq 'ni' ; - $n = $p->cq if $cmd eq 'nz' ; - push @out, $n unless grep $_ eq $n, @out; - } + if ($cmd eq 'ns' && $v =~ /^[A-Z][A-Z]$/i) { + push @out, uc $v unless grep $_ eq uc $v, @out; + } else { + my @pre = Prefix::extract($v); + if (@pre) { + shift @pre; + foreach my $p (@pre) { + my $n = $p->dxcc if $cmd eq 'nc' ; + $n = $p->itu if $cmd eq 'ni' ; + $n = $p->cq if $cmd eq 'nz' ; + $n = $p->state if $cmd eq 'ns'; + push @out, $n unless grep $_ eq $n, @out; + } + } + } } } return @out; @@ -401,29 +444,27 @@ my %valid = ( name => '0,Name', itu => '0,ITU', cq => '0,CQ', + state => '0,State', + city => '0,City', utcoff => '0,UTC offset', cont => '0,Continent', ); -no strict; sub AUTOLOAD { my $self = shift; + no strict; my $name = $AUTOLOAD; return if $name =~ /::DESTROY$/; - $name =~ s/.*:://o; + $name =~ s/^.*:://o; confess "Non-existant field '$AUTOLOAD'" if !$valid{$name}; # this clever line of code creates a subroutine which takes over from autoload # from OO Perl - Conway - *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ; - if (@_) { - $self->{$name} = shift; - } - return $self->{$name}; + *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ; + &$AUTOLOAD($self, @_); } -use strict; # # return a prompt for a field diff --git a/perl/Prot.pm b/perl/Prot.pm index be1d6282..17e3d517 100644 --- a/perl/Prot.pm +++ b/perl/Prot.pm @@ -53,15 +53,18 @@ sub new sub AUTOLOAD { - no strict "refs"; +# no strict "refs"; my $self = shift; + no strict; my $name = $AUTOLOAD; return if $name =~ /::DESTROY$/; - $name =~ s/.*:://o; + $name =~ s/^.*:://o; confess "Non-existant field '$AUTOLOAD'" if !$valid{$name}; - *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ; - @_ ? $self->{$name} = shift : $self->{$name} ; + *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}}; + &$AUTOLOAD($self, @_); +# *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ; +# @_ ? $self->{$name} = shift : $self->{$name} ; } 1; diff --git a/perl/Route.pm b/perl/Route.pm index 7112734f..38740766 100644 --- a/perl/Route.pm +++ b/perl/Route.pm @@ -35,6 +35,8 @@ use vars qw(%list %valid $filterdef); dxcc => '0,Country Code', itu => '0,ITU Zone', cq => '0,CQ Zone', + state => '0,State', + city => '0,City', ); $filterdef = bless ([ @@ -44,9 +46,16 @@ $filterdef = bless ([ ['channel_itu', 'ni', 2], ['channel_zone', 'nz', 3], ['call', 'c', 4], + ['by', 'c', 4], ['call_dxcc', 'nc', 5], + ['by_dxcc', 'nc', 5], ['call_itu', 'ni', 6], + ['by_itu', 'ni', 6], ['call_zone', 'nz', 7], + ['by_zone', 'nz', 7], + ['channel_state', 'ns', 8], + ['call_state', 'ns', 9], + ['by_state', 'ns', 9], ], 'Filter::Cmd'); @@ -63,7 +72,9 @@ sub new if (@dxcc > 0) { $self->{dxcc} = $dxcc[1]->dxcc; $self->{itu} = $dxcc[1]->itu; - $self->{cq} = $dxcc[1]->cq; + $self->{cq} = $dxcc[1]->cq; + $self->{state} = $dxcc[1]->state; + $self->{city} = $dxcc[1]->city; } $self->{flags} = here(1); @@ -370,16 +381,19 @@ sub field_prompt sub AUTOLOAD { my $self = shift; + no strict; my $name = $AUTOLOAD; return if $name =~ /::DESTROY$/; - $name =~ s/.*:://o; + $name =~ s/^.*:://o; confess "Non-existant field '$AUTOLOAD'" if !$valid{$name}; # this clever line of code creates a subroutine which takes over from autoload # from OO Perl - Conway -# *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ; - @_ ? $self->{$name} = shift : $self->{$name} ; + *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}}; + &$AUTOLOAD($self, @_); + +# @_ ? $self->{$name} = shift : $self->{$name} ; } 1; diff --git a/perl/Spot.pm b/perl/Spot.pm index 9b67cc5f..982f8db5 100644 --- a/perl/Spot.pm +++ b/perl/Spot.pm @@ -50,7 +50,10 @@ $filterdef = bless ([ ['call_zone', 'nz', 9], ['by_itu', 'ni', 10], ['by_zone', 'nz', 11], - ['channel', 'c', 12], + ['call_state', 'ns', 12], + ['by_state', 'ns', 13], + ['channel', 'c', 14], + ], 'Filter::Cmd'); $totalspots = $hfspots = $vhfspots = 0; @@ -122,19 +125,28 @@ sub prepare # remove leading and trailing spaces $_[3] = unpad($_[3]); + my ($spotted_dxcc, $spotted_itu, $spotted_cq, $spotted_state) = (666, 0, 0, ""); + my ($spotter_dxcc, $spotter_itu, $spotter_cq, $spotter_state) = (666, 0, 0, ""); + # add the 'dxcc' country on the end for both spotted and spotter, then the cluster call my @dxcc = Prefix::extract($out[1]); - my $spotted_dxcc = (@dxcc > 0 ) ? $dxcc[1]->dxcc() : 666; - my $spotted_itu = (@dxcc > 0 ) ? $dxcc[1]->itu() : 0; - my $spotted_cq = (@dxcc > 0 ) ? $dxcc[1]->cq() : 0; + if (@dxcc) { + $spotted_dxcc = $dxcc[1]->dxcc(); + $spotted_itu = $dxcc[1]->itu(); + $spotted_cq = $dxcc[1]->cq(); + $spotted_state = $dxcc[1]->state(); + } push @out, $spotted_dxcc; @dxcc = Prefix::extract($out[4]); - my $spotter_dxcc = (@dxcc > 0 ) ? $dxcc[1]->dxcc() : 666; - my $spotter_itu = (@dxcc > 0 ) ? $dxcc[1]->itu() : 0; - my $spotter_cq = (@dxcc > 0 ) ? $dxcc[1]->cq() : 0; + if (@dxcc) { + $spotter_dxcc = $dxcc[1]->dxcc(); + $spotter_itu = $dxcc[1]->itu(); + $spotter_cq = $dxcc[1]->cq(); + $spotter_state = $dxcc[1]->state(); + } push @out, $spotter_dxcc; push @out, $_[5]; - return (@out, $spotted_itu, $spotted_cq, $spotter_itu, $spotter_cq); + return (@out, $spotted_itu, $spotted_cq, $spotter_itu, $spotter_cq, $spotted_state, $spotter_state); } sub add @@ -317,7 +329,7 @@ sub dup unpad($text); $text = pack("C*", map {$_ & 127} unpack("C*", $text)); $text =~ s/[^a-zA-Z0-9]//g; - for (0,60,120,180,240,300) { + for (-60, -120, -180, -240, 0, 60, 120, 180, 240, 300) { my $dt = $d - $_; my $dupkey = "X$freq|$call|$dt|\L$text"; return 1 if DXDupe::find($dupkey); diff --git a/perl/USDB.pm b/perl/USDB.pm index ed519b4b..89cd9fe5 100644 --- a/perl/USDB.pm +++ b/perl/USDB.pm @@ -28,7 +28,12 @@ $dbfn = "$main::data/usdb.v1"; sub init { end(); - tie %db, 'DB_File', $dbfn and $present = 1; + if (tie %db, 'DB_File', $dbfn, O_RDONLY, 0664, $DB_BTREE) { + $present = 1; + dbg("US Database loaded"); + } else { + dbg("US Database not loaded"); + } } sub end @@ -122,6 +127,7 @@ sub load untie %dbn; rename "$dbfn.new", $dbfn; + return (); } 1; diff --git a/perl/cluster.pl b/perl/cluster.pl index 04a845d6..c4a61fd2 100755 --- a/perl/cluster.pl +++ b/perl/cluster.pl @@ -396,6 +396,7 @@ dbg("DXSpider Version $version, build $build started"); # load Prefixes dbg("loading prefixes ..."); Prefix::load(); +USDB::init(); # load band data dbg("loading band data ..."); -- 2.43.0