remove Prot.pm, sort %valid fields

[spider.git] / perl / Prefix.pm

diff --git a/perl/Prefix.pm b/perl/Prefix.pm
index bc8a0edf92ea3f411b6e2f242fe6eef824a228ad..086e0725284c6524fe11900e252a3fdf082f3345 100644 (file)
--- a/perl/Prefix.pm
+++ b/perl/Prefix.pm
@@ -3,7 +3,7 @@
 #
 # Copyright (c) - Dirk Koopman G1TLH
 #
-# $Id$
+#
 #
 
 package Prefix;
@@ -19,12 +19,6 @@ use LRU;
 
 use strict;
 
-use vars qw($VERSION $BRANCH);
-$VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
-$BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
-$main::build += $VERSION;
-$main::branch += $BRANCH;
-
 use vars qw($db %prefix_loc %pre $lru $lrusize $misses $hits $matchtotal);
 
 $db = undef;                                   # the DB_File handle
@@ -76,10 +70,10 @@ sub load
        }
 
        # tie the main prefix database
-       $db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0664, $DB_BTREE) or confess "can't tie \%pre ($!)";  
-       my $out = $@ if $@;
-       do "$main::data/prefix_data.pl" if !$out;
-       $out = $@ if $@;
+       eval {$db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0664, $DB_BTREE);};
+       my $out = "$@($!)" if !$db || $@ ;
+       eval {do "$main::data/prefix_data.pl" if !$out; };
+       $out .= $@ if $@;
        $lru = LRU->newbase('Prefix', $lrusize);
 
        return $out;
@@ -176,6 +170,7 @@ sub next
 sub lru_put
 {
        my ($call, $ref) = @_;
+       $call =~ s/^=//;
        my @s = USDB::get($call);
        
        if (@s) {
@@ -251,12 +246,26 @@ sub extract
 
 LM:    foreach $call (split /,/, $calls) {
 
-               # first check if the whole thing succeeds either because it is cached
-               # or because it simply is a stored prefix as callsign (or even a prefix)
                $matchtotal++;
                $call =~ s/-\d+$//;             # ignore SSIDs
-               my $p = $lru->get($call);
                my @nout;
+               my $ecall = "=$call";
+
+               # first check if this is a call (by prefixing it with an = sign)
+               my $p = $lru->get($ecall);
+               if ($p) {
+                       $hits++;
+                       if (isdbg('prefix')) {
+                               my $percent = sprintf "%.1f", $hits * 100 / $misses;
+                               dbg("Prefix Exact Cache Hit: $call Hits: $hits/$misses of $matchtotal = $percent\%");
+                       }
+                       push @out, @$p;
+                       next;
+               }
+
+               # then check if the whole thing succeeds either because it is cached
+               # or because it simply is a stored prefix as callsign (or even a prefix)
+               $p = $lru->get($call);
                if ($p) {
                        $hits++;
                        if (isdbg('prefix')) {
@@ -265,26 +274,37 @@ LM:       foreach $call (split /,/, $calls) {
                        }
                        push @out, @$p;
                        next;
+               }
+
+               # is it in the USDB, force a matchprefix to match?
+               my @s = USDB::get($call);
+               if (@s) {
+                       @nout = get($call);
+                       @nout = matchprefix($call) unless @nout;
+                       $nout[0] = $ecall if @nout;
                } else {
-                       
-                       # is it in the USDB, force a matchprefix to match?
-                       my @s = USDB::get($call);
-                       if (@s) {
-                               @nout = get($call);
-                               @nout = matchprefix($call) unless @nout;
-                               $nout[0] = $call if @nout;
-                       } else {
-                               @nout =  get($call);
-                       }
 
-                       # now store it
-                       if (@nout && $nout[0] eq $call) {
-                               $misses++;
-                               lru_put($call, \@nout);
-                               dbg("got exact prefix: $nout[0]") if isdbg('prefix');
-                               push @out, @nout;
-                               next;
-                       }
+                       # try a straight get for an exact callsign
+                       @nout = get($ecall);
+               }
+
+               # now store the exact prefix if it has been found
+               if (@nout && $nout[0] eq $ecall) {
+                       $misses++;
+                       $nout[0] = $call;
+                       lru_put("=$call", \@nout);
+                       dbg("got exact prefix: $nout[0]") if isdbg('prefix');
+                       push @out, @nout;
+                       next;
+               }
+
+               # now try a non-exact call/prefix
+               if ((@nout = get($call)) && $nout[0] eq $call) {
+                       $misses++;
+                       lru_put($call, \@nout);
+                       dbg("got exact prefix: $nout[0]") if isdbg('prefix');
+                       push @out, @nout;
+                       next;
                }
 
                # now split the call into parts if required
@@ -422,7 +442,7 @@ L1:         for ($n = 0; $n < @parts; $n++) {
                }
 
                # we are a pirate!
-               @nout = matchprefix('Q');
+               @nout = matchprefix('QQ');
                $misses++;
                lru_put($call, \@nout);
                push @out, @nout;
@@ -481,22 +501,26 @@ sub cty_data
        
        my @dxcc = extract($call);
        if (@dxcc) {
-               return ($dxcc[1]->dxcc, $dxcc[1]->itu, $dxcc[1]->cq, $dxcc[1]->state, $dxcc[1]->city);
+               my $state = $dxcc[1]->state || '';
+               my $city = $dxcc[1]->city || '';
+               my $name = $dxcc[1]->name || '';
+               
+               return ($dxcc[1]->dxcc, $dxcc[1]->itu, $dxcc[1]->cq, $state, $city, $name);
        }
-       return (666,0,0,'','');         
+       return (666,0,0,'','','Pirate-Country-QQ');             
 }
 
 my %valid = (
+                        city => '0,City',
+                        cont => '0,Continent',
+                        cq => '0,CQ',
+                        dxcc => '0,DXCC',
+                        itu => '0,ITU',
                         lat => '0,Latitude,slat',
                         long => '0,Longitude,slong',
-                        dxcc => '0,DXCC',
                         name => '0,Name',
-                        itu => '0,ITU',
-                        cq => '0,CQ',
                         state => '0,State',
-                        city => '0,City',
                         utcoff => '0,UTC offset',
-                        cont => '0,Continent',
                        );
 
 sub AUTOLOAD