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