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