X-Git-Url: http://dxcluster.net/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FPrefix.pm;h=37afddf7c075e7d00efefb143e0585d4b58bdc2f;hb=7d4b15681464d77945e7ea78ef60ed3305d57d95;hp=a07ebdbdde8ff5dc8fd727bd5784829b1729001c;hpb=f87323c2926605792ee02b84783d8f3d4dbd605f;p=spider.git diff --git a/perl/Prefix.pm b/perl/Prefix.pm index a07ebdbd..37afddf7 100644 --- a/perl/Prefix.pm +++ b/perl/Prefix.pm @@ -3,7 +3,7 @@ # # Copyright (c) - Dirk Koopman G1TLH # -# $Id$ +# # package Prefix; @@ -14,16 +14,12 @@ use DB_File; use Data::Dumper; use DXDebug; use DXUtil; +use USDB; use LRU; +use DXBearing; use strict; -use vars qw($VERSION $BRANCH); -$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ ); -$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/ || (0,0)); -$main::build += $VERSION; -$main::branch += $BRANCH; - use vars qw($db %prefix_loc %pre $lru $lrusize $misses $hits $matchtotal); $db = undef; # the DB_File handle @@ -32,7 +28,35 @@ $db = undef; # the DB_File handle $hits = $misses = $matchtotal = 1; # cache stats $lrusize = 1000; # size of prefix LRU cache -$lru = LRU->newbase('Prefix', $lrusize); +sub init +{ + my $r = load(); + return $r if $r; + + # fix up the node's default country codes + unless (@main::my_cc) { + push @main::my_cc, (61..67) if $main::mycall =~ /^GB/; + push @main::my_cc, qw(EA EA6 EA8 EA9) if $main::mycall =~ /^E[ABCD]/; + push @main::my_cc, qw(I IT IS) if $main::mycall =~ /^I/; + push @main::my_cc, qw(SV SV5 SV9) if $main::mycall =~ /^SV/; + + # catchall + push @main::my_cc, $main::mycall unless @main::my_cc; + } + + my @c; + for (@main::my_cc) { + if (/^\d+$/) { + push @c, $_; + } else { + my @dxcc = extract($_); + push @c, $dxcc[1]->dxcc if @dxcc > 1; + } + } + return "\@main::my_cc does not contain a valid prefix or callsign (" . join(',', @main::my_cc) . ")" unless @c; + @main::my_cc = @c; + return undef; +} sub load { @@ -42,61 +66,29 @@ sub load untie %pre; %pre = (); %prefix_loc = (); + $lru->close if $lru; + undef $lru; } # tie the main prefix database - $db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0664, $DB_BTREE) or confess "can't tie \%pre ($!)"; - my $out = $@ if $@; - do "$main::data/prefix_data.pl" if !$out; - $out = $@ if $@; + eval {$db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0664, $DB_BTREE);}; + my $out = "$@($!)" if !$db || $@ ; + my $fn = localdata("prefix_data.pl"); + die "Prefix.pm: cannot find $fn, have you run /spider/perl/create_prefix.pl?" unless -e $fn; + + eval {do $fn if !$out; }; + $out .= $@ if $@; + $lru = LRU->newbase('Prefix', $lrusize); return $out; } -sub store +sub loaded { - my ($k, $l); - my $fh = new IO::File; - my $fn = "$main::data/prefix_data.pl"; - - confess "Prefix system not started" if !$db; - - # save versions! - rename "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo"; - rename "$fn.ooo", "$fn.oooo" if -e "$fn.ooo"; - rename "$fn.oo", "$fn.ooo" if -e "$fn.oo"; - rename "$fn.o", "$fn.oo" if -e "$fn.o"; - rename "$fn", "$fn.o" if -e "$fn"; - - $fh->open(">$fn") or die "Can't open $fn ($!)"; - - # prefix location data - $fh->print("%prefix_loc = (\n"); - foreach $l (sort {$a <=> $b} keys %prefix_loc) { - my $r = $prefix_loc{$l}; - $fh->printf(" $l => bless( { name => '%s', dxcc => %d, itu => %d, utcoff => %d, lat => %f, long => %f }, 'Prefix'),\n", - $r->{name}, $r->{dxcc}, $r->{itu}, $r->{cq}, $r->{utcoff}, $r->{lat}, $r->{long}); - } - $fh->print(");\n\n"); - - # prefix data - $fh->print("%pre = (\n"); - foreach $k (sort keys %pre) { - $fh->print(" '$k' => ["); - my @list = @{$pre{$k}}; - my $l; - my $str; - foreach $l (@list) { - $str .= " $l,"; - } - chop $str; - $fh->print("$str ],\n"); - } - $fh->print(");\n"); - undef $fh; - untie %pre; + return $db; } + # what you get is a list that looks like:- # # prefix => @list of blessed references to prefix_locs @@ -129,7 +121,33 @@ 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) = @_; + $call =~ s/^=//; + 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 +171,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 +182,6 @@ sub matchprefix dbg("Partial prefix: $pref $s $part" ); } if (@out && $out[0] eq $s) { - $lru->put($_, \@out) for @partials; return @out; } } @@ -190,12 +207,26 @@ sub extract LM: foreach $call (split /,/, $calls) { - # first check if the whole thing succeeds either because it is cached - # or because it simply is a stored prefix as callsign (or even a prefix) $matchtotal++; $call =~ s/-\d+$//; # ignore SSIDs - my $p = $lru->get($call); my @nout; + my $ecall = "=$call"; + + # first check if this is a call (by prefixing it with an = sign) + my $p = $lru->get($ecall); + if ($p) { + $hits++; + if (isdbg('prefix')) { + my $percent = sprintf "%.1f", $hits * 100 / $misses; + dbg("Prefix Exact Cache Hit: $call Hits: $hits/$misses of $matchtotal = $percent\%"); + } + push @out, @$p; + next; + } + + # then check if the whole thing succeeds either because it is cached + # or because it simply is a stored prefix as callsign (or even a prefix) + $p = $lru->get($call); if ($p) { $hits++; if (isdbg('prefix')) { @@ -204,15 +235,37 @@ LM: foreach $call (split /,/, $calls) { } push @out, @$p; next; + } + + # 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] = $ecall if @nout; } else { - @nout = get($call); - if (@nout && $nout[0] eq $call) { - $misses++; - $lru->put($call, \@nout); - dbg("got exact prefix: $nout[0]") if isdbg('prefix'); - push @out, @nout; - next; - } + + # try a straight get for an exact callsign + @nout = get($ecall); + } + + # now store the exact prefix if it has been found + if (@nout && $nout[0] eq $ecall) { + $misses++; + $nout[0] = $call; + lru_put("=$call", \@nout); + dbg("got exact prefix: $nout[0]") if isdbg('prefix'); + push @out, @nout; + next; + } + + # now try a non-exact call/prefix + if ((@nout = get($call)) && $nout[0] eq $call) { + $misses++; + lru_put($call, \@nout); + dbg("got exact prefix: $nout[0]") if isdbg('prefix'); + push @out, @nout; + next; } # now split the call into parts if required @@ -229,7 +282,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 +302,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 +325,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 +341,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 +386,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; @@ -350,9 +403,9 @@ L1: for ($n = 0; $n < @parts; $n++) { } # we are a pirate! - @nout = matchprefix('Q'); + @nout = matchprefix('QQ'); $misses++; - $lru->put($call, \@nout); + lru_put($call, \@nout); push @out, @nout; } @@ -363,6 +416,61 @@ L1: for ($n = 0; $n < @parts; $n++) { return @out; } +# +# turn a list of prefixes / dxcc numbers into a list of dxcc/itu/zone numbers +# +# nc = dxcc +# ni = itu +# nz = zone +# ns = state +# + +sub to_ciz +{ + my $cmd = shift; + my @out; + + foreach my $v (@_) { + if ($cmd ne 'ns' && $v =~ /^\d+$/) { + push @out, $v unless grep $_ eq $v, @out; + } else { + 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; +} + +# get the full country data (dxcc, itu, cq, state, city) as a list +# from a callsign. +sub cty_data +{ + my $call = shift; + + my @dxcc = extract($call); + if (@dxcc) { + my $state = $dxcc[1]->state || ''; + my $city = $dxcc[1]->city || ''; + my $name = $dxcc[1]->name || ''; + + return ($dxcc[1]->dxcc, $dxcc[1]->itu, $dxcc[1]->cq, $state, $city, $name); + } + return (666,0,0,'','','Pirate-Country-QQ'); +} + my %valid = ( lat => '0,Latitude,slat', long => '0,Longitude,slong', @@ -370,29 +478,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', + qra => '0,Locator', ); -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}} ; + goto &$AUTOLOAD; } -use strict; # # return a prompt for a field