]> dxcluster.net Git - spider.git/blob - perl/Prefix.pm
remove all traces of Aranea.
[spider.git] / perl / Prefix.pm
1 #
2 # prefix handling
3 #
4 # Copyright (c) - Dirk Koopman G1TLH
5 #
6 # $Id$
7 #
8
9 package Prefix;
10
11 use IO::File;
12 use DXVars;
13 use DB_File;
14 use Data::Dumper;
15 use DXDebug;
16 use DXUtil;
17 use USDB;
18 use LRU;
19
20 use strict;
21
22 use vars qw($VERSION $BRANCH);
23 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
24 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
25 $main::build += $VERSION;
26 $main::branch += $BRANCH;
27
28 use vars qw($db %prefix_loc %pre $lru $lrusize $misses $hits $matchtotal);
29
30 $db = undef;                                    # the DB_File handle
31 %prefix_loc = ();                               # the meat of the info
32 %pre = ();                                              # the prefix list
33 $hits = $misses = $matchtotal = 1;              # cache stats
34 $lrusize = 1000;                                # size of prefix LRU cache
35
36 sub init
37 {
38         my $r = load();
39         return $r if $r;
40
41         # fix up the node's default country codes
42         unless (@main::my_cc) {
43                 push @main::my_cc, (61..67) if $main::mycall =~ /^GB/;
44                 push @main::my_cc, qw(EA EA6 EA8 EA9) if $main::mycall =~ /^E[ABCD]/;
45                 push @main::my_cc, qw(I IT IS) if $main::mycall =~ /^I/;
46                 push @main::my_cc, qw(SV SV5 SV9) if $main::mycall =~ /^SV/;
47
48                 # catchall
49                 push @main::my_cc, $main::mycall unless @main::my_cc;
50         }
51
52         my @c;
53         for (@main::my_cc) {
54                 if (/^\d+$/) {
55                         push @c, $_;
56                 } else {
57                         my @dxcc = extract($_);
58                         push @c, $dxcc[1]->dxcc if @dxcc > 1;
59                 }
60         }
61         return "\@main::my_cc does not contain a valid prefix or callsign (" . join(',', @main::my_cc) . ")" unless @c;
62         @main::my_cc = @c;
63         return undef;
64 }
65
66 sub load
67 {
68         # untie every thing
69         if ($db) {
70                 undef $db;
71                 untie %pre;
72                 %pre = ();
73                 %prefix_loc = ();
74                 $lru->close if $lru;
75                 undef $lru;
76         }
77
78         # tie the main prefix database
79         eval {$db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0664, $DB_BTREE);};
80         my $out = "$@($!)" if !$db || $@ ;
81         eval {do "$main::data/prefix_data.pl" if !$out; };
82         $out .= $@ if $@;
83         $lru = LRU->newbase('Prefix', $lrusize);
84
85         return $out;
86 }
87
88 sub loaded
89 {
90         return $db;
91 }
92
93 sub store
94 {
95         my ($k, $l);
96         my $fh = new IO::File;
97         my $fn = "$main::data/prefix_data.pl";
98   
99         confess "Prefix system not started" if !$db;
100   
101         # save versions!
102         rename "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo";
103         rename "$fn.ooo", "$fn.oooo" if -e "$fn.ooo";
104         rename "$fn.oo", "$fn.ooo" if -e "$fn.oo";
105         rename "$fn.o", "$fn.oo" if -e "$fn.o";
106         rename "$fn", "$fn.o" if -e "$fn";
107   
108         $fh->open(">$fn") or die "Can't open $fn ($!)";
109
110         # prefix location data
111         $fh->print("%prefix_loc = (\n");
112         foreach $l (sort {$a <=> $b} keys %prefix_loc) {
113                 my $r = $prefix_loc{$l};
114                 $fh->printf("   $l => bless( { name => '%s', dxcc => %d, itu => %d, utcoff => %d, lat => %f, long => %f }, 'Prefix'),\n",
115                                         $r->{name}, $r->{dxcc}, $r->{itu}, $r->{cq}, $r->{utcoff}, $r->{lat}, $r->{long});
116         }
117         $fh->print(");\n\n");
118
119         # prefix data
120         $fh->print("%pre = (\n");
121         foreach $k (sort keys %pre) {
122                 $fh->print("   '$k' => [");
123                 my @list = @{$pre{$k}};
124                 my $l;
125                 my $str;
126                 foreach $l (@list) {
127                         $str .= " $l,";
128                 }
129                 chop $str;  
130                 $fh->print("$str ],\n");
131         }
132         $fh->print(");\n");
133         undef $fh;
134         untie %pre; 
135 }
136
137 # what you get is a list that looks like:-
138
139 # prefix => @list of blessed references to prefix_locs 
140 #
141 # This routine will only do what you ask for, if you wish to be intelligent
142 # then that is YOUR problem!
143 #
144
145 sub get
146 {
147         my $key = shift;
148         my $ref;
149         my $gotkey = $key;
150         return () if $db->seq($gotkey, $ref, R_CURSOR);
151         return () if $key ne substr $gotkey, 0, length $key;
152
153         return ($gotkey,  map { $prefix_loc{$_} } split ',', $ref);
154 }
155
156 #
157 # get the next key that matches, this assumes that you have done a 'get' first
158 #
159
160 sub next
161 {
162         my $key = shift;
163         my $ref;
164         my $gotkey;
165   
166         return () if $db->seq($gotkey, $ref, R_NEXT);
167         return () if $key ne substr $gotkey, 0, length $key;
168   
169         return ($gotkey,  map { $prefix_loc{$_} } split ',', $ref);
170 }
171
172 #
173 # put the key LRU incluing the city state info
174 #
175
176 sub lru_put
177 {
178         my ($call, $ref) = @_;
179         my @s = USDB::get($call);
180         
181         if (@s) {
182                 # this is deep magic, because this is a reference to static data, it
183         # must be copied.
184                 my $h = { %{$ref->[1]} };
185                 bless $h, ref $ref->[1];
186                 $h->{city} = $s[0];
187                 $h->{state} = $s[1];
188                 $ref->[1] = $h;
189         } else {
190                 $ref->[1]->{city} = $ref->[1]->{state} = "" unless exists $ref->[1]->{state};
191         }
192         
193         dbg("Prefix::lru_put $call -> ($ref->[1]->{city}, $ref->[1]->{state})") if isdbg('prefix');
194         $lru->put($call, $ref);
195 }
196
197
198 # search for the nearest match of a prefix string (starting
199 # from the RH end of the string passed)
200 #
201
202 sub matchprefix
203 {
204         my $pref = shift;
205         my @partials;
206
207         for (my $i = length $pref; $i; $i--) {
208                 $matchtotal++;
209                 my $s = substr($pref, 0, $i);
210                 push @partials, $s;
211                 my $p = $lru->get($s);
212                 if ($p) {
213                         $hits++;
214                         if (isdbg('prefix')) {
215                                 my $percent = sprintf "%.1f", $hits * 100 / $misses;
216                                 dbg("Partial Prefix Cache Hit: $s Hits: $hits/$misses of $matchtotal = $percent\%");
217                         }
218                         lru_put($_, $p) for @partials;
219                         return @$p;
220                 } else {
221                         $misses++;
222                         my @out = get($s);
223                         if (isdbg('prefix')) {
224                                 my $part = $out[0] || "*";
225                                 $part .= '*' unless $part eq '*' || $part eq $s;
226                                 dbg("Partial prefix: $pref $s $part" );
227                         } 
228                         if (@out && $out[0] eq $s) {
229                                 return @out;
230                         } 
231                 }
232         }
233         return ();
234 }
235
236 #
237 # extract a 'prefix' from a callsign, in other words the largest entity that will
238 # obtain a result from the prefix table.
239 #
240 # This is done by repeated probing, callsigns of the type VO1/G1TLH or
241 # G1TLH/VO1 (should) return VO1
242 #
243
244 sub extract
245 {
246         my $calls = uc shift;
247         my @out;
248         my $p;
249         my @parts;
250         my ($call, $sp, $i);
251
252 LM:     foreach $call (split /,/, $calls) {
253
254                 # first check if the whole thing succeeds either because it is cached
255                 # or because it simply is a stored prefix as callsign (or even a prefix)
256                 $matchtotal++;
257                 $call =~ s/-\d+$//;             # ignore SSIDs
258                 my $p = $lru->get($call);
259                 my @nout;
260                 if ($p) {
261                         $hits++;
262                         if (isdbg('prefix')) {
263                                 my $percent = sprintf "%.1f", $hits * 100 / $misses;
264                                 dbg("Prefix Cache Hit: $call Hits: $hits/$misses of $matchtotal = $percent\%");
265                         }
266                         push @out, @$p;
267                         next;
268                 } else {
269                         
270                         # is it in the USDB, force a matchprefix to match?
271                         my @s = USDB::get($call);
272                         if (@s) {
273                                 @nout = get($call);
274                                 @nout = matchprefix($call) unless @nout;
275                                 $nout[0] = $call if @nout;
276                         } else {
277                                 @nout =  get($call);
278                         }
279
280                         # now store it
281                         if (@nout && $nout[0] eq $call) {
282                                 $misses++;
283                                 lru_put($call, \@nout);
284                                 dbg("got exact prefix: $nout[0]") if isdbg('prefix');
285                                 push @out, @nout;
286                                 next;
287                         }
288                 }
289
290                 # now split the call into parts if required
291                 @parts = ($call =~ '/') ? split('/', $call) : ($call);
292                 dbg("Parts: $call = " . join(' ', @parts))      if isdbg('prefix');
293
294                 # remove any /0-9 /P /A /M /MM /AM suffixes etc
295                 if (@parts > 1) {
296                         @parts = grep { !/^\d+$/ && !/^[PABM]$/ && !/^(?:|AM|MM|BCN|JOTA|SIX|WEB|NET|Q\w+)$/; } @parts;
297
298                         # can we resolve them by direct lookup
299                         my $s = join('/', @parts); 
300                         @nout = get($s);
301                         if (@nout && $nout[0] eq $s) {
302                                 dbg("got exact multipart prefix: $call $s") if isdbg('prefix');
303                                 $misses++;
304                                 lru_put($call, \@nout);
305                                 push @out, @nout;
306                                 next;
307                         }
308                 }
309                 dbg("Parts now: $call = " . join(' ', @parts))  if isdbg('prefix');
310   
311                 # at this point we should have two or three parts
312                 # if it is three parts then join the first and last parts together
313                 # to get an answer
314
315                 # first deal with prefix/x00xx/single letter things
316                 if (@parts == 3 && length $parts[0] <= length $parts[1]) {
317                         @nout = matchprefix($parts[0]);
318                         if (@nout) {
319                                 my $s = join('/', $nout[0], $parts[2]);
320                                 my @try = get($s);
321                                 if (@try && $try[0] eq $s) {
322                                         dbg("got 3 part prefix: $call $s") if isdbg('prefix');
323                                         $misses++;
324                                         lru_put($call, \@try);
325                                         push @out, @try;
326                                         next;
327                                 }
328                                 
329                                 # if the second part is a callsign and the last part is one letter
330                                 if (is_callsign($parts[1]) && length $parts[2] == 1) {
331                                         pop @parts;
332                                 }
333                         }
334                 }
335
336                 # if it is a two parter 
337                 if (@parts == 2) {
338
339                         # try it as it is as compound, taking the first part as the prefix
340                         @nout = matchprefix($parts[0]);
341                         if (@nout) {
342                                 my $s = join('/', $nout[0], $parts[1]);
343                                 my @try = get($s);
344                                 if (@try && $try[0] eq $s) {
345                                         dbg("got 2 part prefix: $call $s") if isdbg('prefix');
346                                         $misses++;
347                                         lru_put($call, \@try);
348                                         push @out, @try;
349                                         next;
350                                 }
351                         }
352                 }
353
354                 # remove the problematic /J suffix
355                 pop @parts if @parts > 1 && $parts[$#parts] eq 'J';
356
357                 # single parter
358                 if (@parts == 1) {
359                         @nout = matchprefix($parts[0]);
360                         if (@nout) {
361                                 dbg("got prefix: $call = $nout[0]") if isdbg('prefix');
362                                 $misses++;
363                                 lru_put($call, \@nout);
364                                 push @out, @nout;
365                                 next;
366                         }
367                 }
368
369                 # try ALL the parts
370         my @checked;
371                 my $n;
372 L1:             for ($n = 0; $n < @parts; $n++) {
373                         my $sp = '';
374                         my ($k, $i);
375                         for ($i = $k = 0; $i < @parts; $i++) {
376                                 next if $checked[$i];
377                                 my $p = $parts[$i];
378                                 if (!$sp || length $p < length $sp) {
379                                         dbg("try part: $p") if isdbg('prefix');
380                                         $k = $i;
381                                         $sp = $p;
382                                 }
383                         }
384                         $checked[$k] = 1;
385                         $sp =~ s/-\d+$//;     # remove any SSID
386                         
387                         # now start to resolve it from the right hand end
388                         @nout = matchprefix($sp);
389                         
390                         # try and search for it in the descriptions as
391                         # a whole callsign if it has multiple parts and the output
392                         # is more two long, this should catch things like
393                         # FR5DX/T without having to explicitly stick it into
394                         # the prefix table.
395                         
396                         if (@nout) {
397                                 if (@parts > 1) {
398                                         $parts[$k] = $nout[0];
399                                         my $try = join('/', @parts);
400                                         my @try = get($try);
401                                         if (isdbg('prefix')) {
402                                                 my $part = $try[0] || "*";
403                                                 $part .= '*' unless $part eq '*' || $part eq $try;
404                                                 dbg("Compound prefix: $try $part" );
405                                         }
406                                         if (@try && $try eq $try[0]) {
407                                                 $misses++;
408                                                 lru_put($call, \@try);
409                                                 push @out, @try;
410                                         } else {
411                                                 $misses++;
412                                                 lru_put($call, \@nout);
413                                                 push @out, @nout;
414                                         }
415                                 } else {
416                                         $misses++;
417                                         lru_put($call, \@nout);
418                                         push @out, @nout;
419                                 }
420                                 next LM;
421                         }
422                 }
423
424                 # we are a pirate!
425                 @nout = matchprefix('Q');
426                 $misses++;
427                 lru_put($call, \@nout);
428                 push @out, @nout;
429         }
430         
431         if (isdbg('prefixdata')) {
432                 my $dd = new Data::Dumper([ \@out ], [qw(@out)]);
433                 dbg($dd->Dumpxs);
434         }
435         return @out;
436 }
437
438 #
439 # turn a list of prefixes / dxcc numbers into a list of dxcc/itu/zone numbers
440 #
441 # nc = dxcc
442 # ni = itu
443 # nz = zone
444 # ns = state
445 #
446
447 sub to_ciz
448 {
449         my $cmd = shift;
450         my @out;
451         
452         foreach my $v (@_) {
453                 if ($cmd ne 'ns' && $v =~ /^\d+$/) {    
454                         push @out, $v unless grep $_ eq $v, @out;
455                 } else {
456                         if ($cmd eq 'ns' && $v =~ /^[A-Z][A-Z]$/i) {
457                                 push @out, uc $v unless grep $_ eq uc $v, @out;
458                         } else {
459                                 my @pre = Prefix::extract($v);
460                                 if (@pre) {
461                                         shift @pre;
462                                         foreach my $p (@pre) {
463                                                 my $n = $p->dxcc if $cmd eq 'nc' ;
464                                                 $n = $p->itu if $cmd eq 'ni' ;
465                                                 $n = $p->cq if $cmd eq 'nz' ;
466                                                 $n = $p->state if $cmd eq 'ns';
467                                                 push @out, $n unless grep $_ eq $n, @out;
468                                         }
469                                 }
470                         }                       
471                 }
472         }
473         return @out;
474 }
475
476 # get the full country data (dxcc, itu, cq, state, city) as a list
477 # from a callsign. 
478 sub cty_data
479 {
480         my $call = shift;
481         
482         my @dxcc = extract($call);
483         if (@dxcc) {
484                 my $state = $dxcc[1]->state || '';
485                 my $city = $dxcc[1]->city || '';
486                 my $name = $dxcc[1]->name || '';
487                 
488                 return ($dxcc[1]->dxcc, $dxcc[1]->itu, $dxcc[1]->cq, $state, $city, $name);
489         }
490         return (666,0,0,'','','Pirate-Country-QQ');             
491 }
492
493 my %valid = (
494                          lat => '0,Latitude,slat',
495                          long => '0,Longitude,slong',
496                          dxcc => '0,DXCC',
497                          name => '0,Name',
498                          itu => '0,ITU',
499                          cq => '0,CQ',
500                          state => '0,State',
501                          city => '0,City',
502                          utcoff => '0,UTC offset',
503                          cont => '0,Continent',
504                         );
505
506 sub AUTOLOAD
507 {
508         no strict;
509         my $name = $AUTOLOAD;
510   
511         return if $name =~ /::DESTROY$/;
512         $name =~ s/^.*:://o;
513   
514         confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
515         # this clever line of code creates a subroutine which takes over from autoload
516         # from OO Perl - Conway
517         *$AUTOLOAD = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ;
518        goto &$AUTOLOAD;
519 }
520
521 #
522 # return a prompt for a field
523 #
524
525 sub field_prompt
526
527         my ($self, $ele) = @_;
528         return $valid{$ele};
529 }
530 1;
531
532 __END__