4 # Copyright (c) - Dirk Koopman G1TLH
22 use vars qw($db %prefix_loc %pre $lru $lrusize $misses $hits $matchtotal);
24 $db = undef; # the DB_File handle
25 %prefix_loc = (); # the meat of the info
26 %pre = (); # the prefix list
27 $hits = $misses = $matchtotal = 1; # cache stats
28 $lrusize = 1000; # size of prefix LRU cache
35 # fix up the node's default country codes
36 unless (@main::my_cc) {
37 push @main::my_cc, (61..67) if $main::mycall =~ /^GB/;
38 push @main::my_cc, qw(EA EA6 EA8 EA9) if $main::mycall =~ /^E[ABCD]/;
39 push @main::my_cc, qw(I IT IS) if $main::mycall =~ /^I/;
40 push @main::my_cc, qw(SV SV5 SV9) if $main::mycall =~ /^SV/;
43 push @main::my_cc, $main::mycall unless @main::my_cc;
51 my @dxcc = extract($_);
52 push @c, $dxcc[1]->dxcc if @dxcc > 1;
55 return "\@main::my_cc does not contain a valid prefix or callsign (" . join(',', @main::my_cc) . ")" unless @c;
72 # tie the main prefix database
73 eval {$db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0664, $DB_BTREE);};
74 my $out = "$@($!)" if !$db || $@ ;
75 if (-e "$main::data/wpxloc.dat") {
76 $out .= load_wpxloc_dat("$main::data/wpxloc.dat");
77 $out .= load_wpxloc_dat("$main::data/local_wpxloc.dat");
79 eval {do "$main::data/prefix_data.pl" if !$out; };
82 $lru = LRU->newbase('Prefix', $lrusize);
95 my $fh = new IO::File;
96 my $fn = "$main::data/prefix_data.pl";
98 confess "Prefix system not started" if !$db;
101 rename "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo";
102 rename "$fn.ooo", "$fn.oooo" if -e "$fn.ooo";
103 rename "$fn.oo", "$fn.ooo" if -e "$fn.oo";
104 rename "$fn.o", "$fn.oo" if -e "$fn.o";
105 rename "$fn", "$fn.o" if -e "$fn";
107 $fh->open(">$fn") or die "Can't open $fn ($!)";
109 # prefix location data
110 $fh->print("%prefix_loc = (\n");
111 foreach $l (sort {$a <=> $b} keys %prefix_loc) {
112 my $r = $prefix_loc{$l};
113 $fh->printf(" $l => bless( { name => '%s', dxcc => %d, itu => %d, utcoff => %d, lat => %f, long => %f }, 'Prefix'),\n",
114 $r->{name}, $r->{dxcc}, $r->{itu}, $r->{cq}, $r->{utcoff}, $r->{lat}, $r->{long});
116 $fh->print(");\n\n");
119 $fh->print("%pre = (\n");
120 foreach $k (sort keys %pre) {
121 $fh->print(" '$k' => [");
122 my @list = @{$pre{$k}};
129 $fh->print("$str ],\n");
136 # what you get is a list that looks like:-
138 # prefix => @list of blessed references to prefix_locs
140 # This routine will only do what you ask for, if you wish to be intelligent
141 # then that is YOUR problem!
149 return () if $db->seq($gotkey, $ref, R_CURSOR);
150 return () if $key ne substr $gotkey, 0, length $key;
152 return ($gotkey, map { $prefix_loc{$_} } split ',', $ref);
156 # get the next key that matches, this assumes that you have done a 'get' first
165 return () if $db->seq($gotkey, $ref, R_NEXT);
166 return () if $key ne substr $gotkey, 0, length $key;
168 return ($gotkey, map { $prefix_loc{$_} } split ',', $ref);
172 # put the key LRU incluing the city state info
177 my ($call, $ref) = @_;
178 my @s = USDB::get($call);
181 # this is deep magic, because this is a reference to static data, it
183 my $h = { %{$ref->[1]} };
184 bless $h, ref $ref->[1];
189 $ref->[1]->{city} = $ref->[1]->{state} = "" unless exists $ref->[1]->{state};
192 dbg("Prefix::lru_put $call -> ($ref->[1]->{city}, $ref->[1]->{state})") if isdbg('prefix');
193 $lru->put($call, $ref);
197 # search for the nearest match of a prefix string (starting
198 # from the RH end of the string passed)
206 for (my $i = length $pref; $i; $i--) {
208 my $s = substr($pref, 0, $i);
210 my $p = $lru->get($s);
213 if (isdbg('prefix')) {
214 my $percent = sprintf "%.1f", $hits * 100 / $misses;
215 dbg("Partial Prefix Cache Hit: $s Hits: $hits/$misses of $matchtotal = $percent\%");
217 lru_put($_, $p) for @partials;
222 if (isdbg('prefix')) {
223 my $part = $out[0] || "*";
224 $part .= '*' unless $part eq '*' || $part eq $s;
225 dbg("Partial prefix: $pref $s $part" );
227 if (@out && $out[0] eq $s) {
236 # extract a 'prefix' from a callsign, in other words the largest entity that will
237 # obtain a result from the prefix table.
239 # This is done by repeated probing, callsigns of the type VO1/G1TLH or
240 # G1TLH/VO1 (should) return VO1
245 my $calls = uc shift;
251 LM: foreach $call (split /,/, $calls) {
253 # first check if the whole thing succeeds either because it is cached
254 # or because it simply is a stored prefix as callsign (or even a prefix)
256 $call =~ s/-\d+$//; # ignore SSIDs
257 my $p = $lru->get($call);
261 if (isdbg('prefix')) {
262 my $percent = sprintf "%.1f", $hits * 100 / $misses;
263 dbg("Prefix Cache Hit: $call Hits: $hits/$misses of $matchtotal = $percent\%");
269 # is it in the USDB, force a matchprefix to match?
270 my @s = USDB::get($call);
273 @nout = matchprefix($call) unless @nout;
274 $nout[0] = $call if @nout;
280 if (@nout && $nout[0] eq $call) {
282 lru_put($call, \@nout);
283 dbg("got exact prefix: $nout[0]") if isdbg('prefix');
289 # now split the call into parts if required
290 @parts = ($call =~ '/') ? split('/', $call) : ($call);
291 dbg("Parts: $call = " . join(' ', @parts)) if isdbg('prefix');
293 # remove any /0-9 /P /A /M /MM /AM suffixes etc
295 @parts = grep { !/^\d+$/ && !/^[PABM]$/ && !/^(?:|AM|MM|BCN|JOTA|SIX|WEB|NET|Q\w+)$/; } @parts;
297 # can we resolve them by direct lookup
298 my $s = join('/', @parts);
300 if (@nout && $nout[0] eq $s) {
301 dbg("got exact multipart prefix: $call $s") if isdbg('prefix');
303 lru_put($call, \@nout);
308 dbg("Parts now: $call = " . join(' ', @parts)) if isdbg('prefix');
310 # at this point we should have two or three parts
311 # if it is three parts then join the first and last parts together
314 # first deal with prefix/x00xx/single letter things
315 if (@parts == 3 && length $parts[0] <= length $parts[1]) {
316 @nout = matchprefix($parts[0]);
318 my $s = join('/', $nout[0], $parts[2]);
320 if (@try && $try[0] eq $s) {
321 dbg("got 3 part prefix: $call $s") if isdbg('prefix');
323 lru_put($call, \@try);
328 # if the second part is a callsign and the last part is one letter
329 if (is_callsign($parts[1]) && length $parts[2] == 1) {
335 # if it is a two parter
338 # try it as it is as compound, taking the first part as the prefix
339 @nout = matchprefix($parts[0]);
341 my $s = join('/', $nout[0], $parts[1]);
343 if (@try && $try[0] eq $s) {
344 dbg("got 2 part prefix: $call $s") if isdbg('prefix');
346 lru_put($call, \@try);
353 # remove the problematic /J suffix
354 pop @parts if @parts > 1 && $parts[$#parts] eq 'J';
358 @nout = matchprefix($parts[0]);
360 dbg("got prefix: $call = $nout[0]") if isdbg('prefix');
362 lru_put($call, \@nout);
371 L1: for ($n = 0; $n < @parts; $n++) {
374 for ($i = $k = 0; $i < @parts; $i++) {
375 next if $checked[$i];
377 if (!$sp || length $p < length $sp) {
378 dbg("try part: $p") if isdbg('prefix');
384 $sp =~ s/-\d+$//; # remove any SSID
386 # now start to resolve it from the right hand end
387 @nout = matchprefix($sp);
389 # try and search for it in the descriptions as
390 # a whole callsign if it has multiple parts and the output
391 # is more two long, this should catch things like
392 # FR5DX/T without having to explicitly stick it into
397 $parts[$k] = $nout[0];
398 my $try = join('/', @parts);
400 if (isdbg('prefix')) {
401 my $part = $try[0] || "*";
402 $part .= '*' unless $part eq '*' || $part eq $try;
403 dbg("Compound prefix: $try $part" );
405 if (@try && $try eq $try[0]) {
407 lru_put($call, \@try);
411 lru_put($call, \@nout);
416 lru_put($call, \@nout);
424 @nout = matchprefix('Q');
426 lru_put($call, \@nout);
430 if (isdbg('prefixdata')) {
431 my $dd = new Data::Dumper([ \@out ], [qw(@out)]);
438 # turn a list of prefixes / dxcc numbers into a list of dxcc/itu/zone numbers
452 if ($cmd ne 'ns' && $v =~ /^\d+$/) {
453 push @out, $v unless grep $_ eq $v, @out;
455 if ($cmd eq 'ns' && $v =~ /^[A-Z][A-Z]$/i) {
456 push @out, uc $v unless grep $_ eq uc $v, @out;
458 my @pre = Prefix::extract($v);
461 foreach my $p (@pre) {
462 my $n = $p->dxcc if $cmd eq 'nc' ;
463 $n = $p->itu if $cmd eq 'ni' ;
464 $n = $p->cq if $cmd eq 'nz' ;
465 $n = $p->state if $cmd eq 'ns';
466 push @out, $n unless grep $_ eq $n, @out;
475 # get the full country data (dxcc, itu, cq, state, city) as a list
481 my @dxcc = extract($call);
483 my $state = $dxcc[1]->state || '';
484 my $city = $dxcc[1]->city || '';
485 my $name = $dxcc[1]->name || '';
487 return ($dxcc[1]->dxcc, $dxcc[1]->itu, $dxcc[1]->cq, $state, $city, $name);
489 return (666,0,0,'','','Pirate-Country-QQ');
493 lat => '0,Latitude,slat',
494 long => '0,Longitude,slong',
501 utcoff => '0,UTC offset',
502 cont => '0,Continent',
508 my $name = $AUTOLOAD;
510 return if $name =~ /::DESTROY$/;
513 confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
514 # this clever line of code creates a subroutine which takes over from autoload
515 # from OO Perl - Conway
516 *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
521 # return a prompt for a field
526 my ($self, $ele) = @_;
537 return unless -e $fn;
539 my $in = IO::File->new("$fn");
540 $out = "error opening $fn $!", return $out unless $in;
551 # The format of wpxloc.dat is:-
552 # 1S Spratly-Islands-1S 269 AS 50 26 8.00 9 53 N 114 14 E
553 # & 1S,9M0,BV9S,=9M6US/0,=DU0K
554 # & .... can repeat ad nausium
556 unless ($f[0] eq '&') {
557 # main location definition and 'official' canonical prefix/tag for this locality
558 # NOTE: we assume that the file is nominally correct and that any alterations
559 # will overwrite existing entries
561 # The order is: prefix, description, country-no, continent, itu, cq, utc-offset
562 # lat degrees, lat minutes, lat N/S, long degrees, long minutes,
566 $out .= "wrong no of items for locality on line $line\n";
573 my $e = bless {}, 'Prefix';
581 $e->{utcoff} = $f[6];
582 $e->{lat} = $f[7] + ($f[8] / 60);
583 $e->{lat} = -$e->{lat} if $f[9] eq 'S';
584 $e->{long} = $f[10] + ($f[11] / 60);
585 $e->{long} = -$e->{long} if $f[12] eq 'W';
586 $prefix_loc{$id} = $e;
589 # print "line $line, $f[0]\n";
592 # additional prefixes and full callsigns (indicated with an prefix of '=')
597 foreach my $gob (@f) {
598 my @ent = split /\s*,\s*/, $gob;
599 foreach my $ent (@ent) {
601 my $ref = $pre{$ent};
603 my @id = split /,/, $ref;
604 push @id, $id unless grep {$id == $_} @id;
605 $pre{$ent} = join ',', @id;
615 open POUT, ">/tmp/prefix_data";
616 print POUT Data::Dumper->Dump([\%prefix_loc, \%pre], [qw(%prefix_loc %pre)]);