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