4 # Copyright (c) - Dirk Koopman G1TLH
23 use vars qw($db %prefix_loc %pre $lru $lrusize $misses $hits $matchtotal);
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 = 1000; # size of prefix LRU cache
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/;
44 push @main::my_cc, $main::mycall unless @main::my_cc;
52 my @dxcc = extract($_);
53 push @c, $dxcc[1]->dxcc if @dxcc > 1;
56 return "\@main::my_cc does not contain a valid prefix or callsign (" . join(',', @main::my_cc) . ")" unless @c;
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;
79 eval {do $fn if !$out; };
81 $lru = LRU->newbase('Prefix', $lrusize);
92 # what you get is a list that looks like:-
94 # prefix => @list of blessed references to prefix_locs
96 # This routine will only do what you ask for, if you wish to be intelligent
97 # then that is YOUR problem!
105 return () if $db->seq($gotkey, $ref, R_CURSOR);
106 return () if $key ne substr $gotkey, 0, length $key;
108 return ($gotkey, map { $prefix_loc{$_} } split ',', $ref);
112 # get the next key that matches, this assumes that you have done a 'get' first
121 return () if $db->seq($gotkey, $ref, R_NEXT);
122 return () if $key ne substr $gotkey, 0, length $key;
124 return ($gotkey, map { $prefix_loc{$_} } split ',', $ref);
128 # put the key LRU incluing the city state info
133 my ($call, $ref) = @_;
135 my @s = USDB::get($call);
138 # this is deep magic, because this is a reference to static data, it
140 my $h = { %{$ref->[1]} };
141 bless $h, ref $ref->[1];
146 $ref->[1]->{city} = $ref->[1]->{state} = "" unless exists $ref->[1]->{state};
149 dbg("Prefix::lru_put $call -> ($ref->[1]->{city}, $ref->[1]->{state})") if isdbg('prefix');
150 $lru->put($call, $ref);
154 # search for the nearest match of a prefix string (starting
155 # from the RH end of the string passed)
163 for (my $i = length $pref; $i; $i--) {
165 my $s = substr($pref, 0, $i);
167 my $p = $lru->get($s);
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\%");
174 lru_put($_, $p) for @partials;
179 if (isdbg('prefix')) {
180 my $part = $out[0] || "*";
181 $part .= '*' unless $part eq '*' || $part eq $s;
182 dbg("Partial prefix: $pref $s $part" );
184 if (@out && $out[0] eq $s) {
193 # extract a 'prefix' from a callsign, in other words the largest entity that will
194 # obtain a result from the prefix table.
196 # This is done by repeated probing, callsigns of the type VO1/G1TLH or
197 # G1TLH/VO1 (should) return VO1
202 my $calls = uc shift;
208 LM: foreach $call (split /,/, $calls) {
211 $call =~ s/-\d+$//; # ignore SSIDs
213 my $ecall = "=$call";
215 # first check if this is a call (by prefixing it with an = sign)
216 my $p = $lru->get($ecall);
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\%");
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);
232 if (isdbg('prefix')) {
233 my $percent = sprintf "%.1f", $hits * 100 / $misses;
234 dbg("Prefix Cache Hit: $call Hits: $hits/$misses of $matchtotal = $percent\%");
240 # is it in the USDB, force a matchprefix to match?
241 my @s = USDB::get($call);
244 @nout = matchprefix($call) unless @nout;
245 $nout[0] = $ecall if @nout;
248 # try a straight get for an exact callsign
252 # now store the exact prefix if it has been found
253 if (@nout && $nout[0] eq $ecall) {
256 lru_put("=$call", \@nout);
257 dbg("got exact prefix: $nout[0]") if isdbg('prefix');
262 # now try a non-exact call/prefix
263 if ((@nout = get($call)) && $nout[0] eq $call) {
265 lru_put($call, \@nout);
266 dbg("got exact prefix: $nout[0]") if isdbg('prefix');
271 # now split the call into parts if required
272 @parts = ($call =~ '/') ? split('/', $call) : ($call);
273 dbg("Parts: $call = " . join(' ', @parts)) if isdbg('prefix');
275 # remove any /0-9 /P /A /M /MM /AM suffixes etc
277 @parts = grep { !/^\d+$/ && !/^[PABM]$/ && !/^(?:|AM|MM|BCN|JOTA|SIX|WEB|NET|Q\w+)$/; } @parts;
279 # can we resolve them by direct lookup
280 my $s = join('/', @parts);
282 if (@nout && $nout[0] eq $s) {
283 dbg("got exact multipart prefix: $call $s") if isdbg('prefix');
285 lru_put($call, \@nout);
290 dbg("Parts now: $call = " . join(' ', @parts)) if isdbg('prefix');
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
296 # first deal with prefix/x00xx/single letter things
297 if (@parts == 3 && length $parts[0] <= length $parts[1]) {
298 @nout = matchprefix($parts[0]);
300 my $s = join('/', $nout[0], $parts[2]);
302 if (@try && $try[0] eq $s) {
303 dbg("got 3 part prefix: $call $s") if isdbg('prefix');
305 lru_put($call, \@try);
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) {
317 # if it is a two parter
320 # try it as it is as compound, taking the first part as the prefix
321 @nout = matchprefix($parts[0]);
323 my $s = join('/', $nout[0], $parts[1]);
325 if (@try && $try[0] eq $s) {
326 dbg("got 2 part prefix: $call $s") if isdbg('prefix');
328 lru_put($call, \@try);
335 # remove the problematic /J suffix
336 pop @parts if @parts > 1 && $parts[$#parts] eq 'J';
340 @nout = matchprefix($parts[0]);
342 dbg("got prefix: $call = $nout[0]") if isdbg('prefix');
344 lru_put($call, \@nout);
353 L1: for ($n = 0; $n < @parts; $n++) {
356 for ($i = $k = 0; $i < @parts; $i++) {
357 next if $checked[$i];
359 if (!$sp || length $p < length $sp) {
360 dbg("try part: $p") if isdbg('prefix');
366 $sp =~ s/-\d+$//; # remove any SSID
368 # now start to resolve it from the right hand end
369 @nout = matchprefix($sp);
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
379 $parts[$k] = $nout[0];
380 my $try = join('/', @parts);
382 if (isdbg('prefix')) {
383 my $part = $try[0] || "*";
384 $part .= '*' unless $part eq '*' || $part eq $try;
385 dbg("Compound prefix: $try $part" );
387 if (@try && $try eq $try[0]) {
389 lru_put($call, \@try);
393 lru_put($call, \@nout);
398 lru_put($call, \@nout);
406 @nout = matchprefix('QQ');
408 lru_put($call, \@nout);
412 if (isdbg('prefixdata')) {
413 my $dd = new Data::Dumper([ \@out ], [qw(@out)]);
420 # turn a list of prefixes / dxcc numbers into a list of dxcc/itu/zone numbers
434 if ($cmd ne 'ns' && $v =~ /^\d+$/) {
435 push @out, $v unless grep $_ eq $v, @out;
437 if ($cmd eq 'ns' && $v =~ /^[A-Z][A-Z]$/i) {
438 push @out, uc $v unless grep $_ eq uc $v, @out;
440 my @pre = Prefix::extract($v);
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;
457 # get the full country data (dxcc, itu, cq, state, city) as a list
463 my @dxcc = extract($call);
465 my $state = $dxcc[1]->state || '';
466 my $city = $dxcc[1]->city || '';
467 my $name = $dxcc[1]->name || '';
469 return ($dxcc[1]->dxcc, $dxcc[1]->itu, $dxcc[1]->cq, $state, $city, $name);
471 return (666,0,0,'','','Pirate-Country-QQ');
475 lat => '0,Latitude,slat',
476 long => '0,Longitude,slong',
483 utcoff => '0,UTC offset',
484 cont => '0,Continent',
491 my $name = $AUTOLOAD;
493 return if $name =~ /::DESTROY$/;
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}} ;
504 # return a prompt for a field
509 my ($self, $ele) = @_;