X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FPrefix.pm;h=36e9fa2a277d717373328fe652864a027107560a;hb=72936494cce7397ff1d08b246b4fd6a8b2c89a44;hp=6f1c1f29a8849f23b4f753d6ab02eae75a905435;hpb=b00e85c55392ddf0593b681d7187e4c4e158568e;p=spider.git diff --git a/perl/Prefix.pm b/perl/Prefix.pm index 6f1c1f29..36e9fa2a 100644 --- a/perl/Prefix.pm +++ b/perl/Prefix.pm @@ -3,7 +3,7 @@ # # Copyright (c) - Dirk Koopman G1TLH # -# $Id$ +# # package Prefix; @@ -19,12 +19,6 @@ use LRU; 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 @@ -33,6 +27,36 @@ $db = undef; # the DB_File handle $hits = $misses = $matchtotal = 1; # cache stats $lrusize = 1000; # size of prefix LRU cache +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 { # untie every thing @@ -46,15 +70,25 @@ sub load } # 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 || $@ ; + if (-e "$main::data/wpxloc.dat") { + $out .= load_wpxloc_dat("$main::data/wpxloc.dat"); + $out .= load_wpxloc_dat("$main::data/local_wpxloc.dat"); + } else { + eval {do "$main::data/prefix_data.pl" if !$out; }; + $out .= $@ if $@; + } $lru = LRU->newbase('Prefix', $lrusize); return $out; } +sub loaded +{ + return $db; +} + sub store { my ($k, $l); @@ -438,6 +472,23 @@ sub to_ciz 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', @@ -453,7 +504,6 @@ my %valid = ( sub AUTOLOAD { - my $self = shift; no strict; my $name = $AUTOLOAD; @@ -464,7 +514,7 @@ sub AUTOLOAD # 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}} ; - &$AUTOLOAD($self, @_); + goto &$AUTOLOAD; } # @@ -476,6 +526,99 @@ sub field_prompt my ($self, $ele) = @_; return $valid{$ele}; } + +sub load_wpxloc_dat +{ + my $fn = shift; + my $out; + my $id = 0; + my $line = 0; + + return unless -e $fn; + + my $in = IO::File->new("$fn"); + $out = "error opening $fn $!", return $out unless $in; + while (<$in>) { + my $ignore = 0; + $line++; + + next if /^\s*[!#]/; + next if /^\s*$/; + s/\s+$//; + + my @f = split; + + # The format of wpxloc.dat is:- + # 1S Spratly-Islands-1S 269 AS 50 26 8.00 9 53 N 114 14 E + # & 1S,9M0,BV9S,=9M6US/0,=DU0K + # & .... can repeat ad nausium + + unless ($f[0] eq '&') { + # main location definition and 'official' canonical prefix/tag for this locality + # NOTE: we assume that the file is nominally correct and that any alterations + # will overwrite existing entries + # + # The order is: prefix, description, country-no, continent, itu, cq, utc-offset + # lat degrees, lat minutes, lat N/S, long degrees, long minutes, + # long E/W + + if (@f != 13) { + $out .= "wrong no of items for locality on line $line\n"; + $ignore++; + next; + } + + $ignore = 0; + + my $e = bless {}, 'Prefix'; + $id++; + + $e->{name} = $f[1]; + $e->{dxcc} = $f[2]; + $e->{cont} = $f[3]; + $e->{itu} = $f[4]; + $e->{cq} = $f[5]; + $e->{utcoff} = $f[6]; + $e->{lat} = $f[7] + ($f[8] / 60); + $e->{lat} = -$e->{lat} if $f[9] eq 'S'; + $e->{long} = $f[10] + ($f[11] / 60); + $e->{long} = -$e->{long} if $f[12] eq 'W'; + $prefix_loc{$id} = $e; + $pre{"$f[0]"} = $id; + +# print "line $line, $f[0]\n"; + + } else { + # additional prefixes and full callsigns (indicated with an prefix of '=') + + next if $ignore; + + shift @f; + foreach my $gob (@f) { + my @ent = split /\s*,\s*/, $gob; + foreach my $ent (@ent) { + $ent =~ s/^\*//; + my $ref = $pre{$ent}; + if ($ref) { + my @id = split /,/, $ref; + push @id, $id unless grep {$id == $_} @id; + $pre{$ent} = join ',', @id; + } else { + $pre{$ent} = $id; + } + } + } + } + } + $in->close; + + open POUT, ">/tmp/prefix_data"; + print POUT Data::Dumper->Dump([\%prefix_loc, \%pre], [qw(%prefix_loc %pre)]); + close POUT; + + return $out; +} + 1; __END__