X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FPrefix.pm;h=246dbb659eb2d53ead8a74d78c110140aec01cb9;hb=5b9ab81174d4a7734c92af52da6ddf89e980e321;hp=0e67801d9e8f10ce494db023877ab5abcf67a439;hpb=0ede244fc4076f902584ee6d088cd7fd7fd2817f;p=spider.git

diff --git a/perl/Prefix.pm b/perl/Prefix.pm
index 0e67801d..246dbb65 100644
--- a/perl/Prefix.pm
+++ b/perl/Prefix.pm
@@ -14,7 +14,7 @@ use DB_File;
 use Data::Dumper;
 use DXDebug;
 use DXUtil;
-
+use LRU;
 
 use strict;
 
@@ -24,28 +24,24 @@ $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 %cache $misses $hits $matchtotal $lasttime);
+use vars qw($db %prefix_loc %pre $lru $lrusize $misses $hits $matchtotal);
 
 $db = undef;					# the DB_File handle
 %prefix_loc = ();				# the meat of the info
 %pre = ();						# the prefix list
-%cache = ();					# a runtime cache of matched prefixes
-$lasttime = 0;					# last time this cache was cleared
 $hits = $misses = $matchtotal = 1;		# cache stats
+$lrusize = 2000;				# size of prefix LRU cache
 
-#my $cachefn = "$main::data/prefix_cache";
+$lru = LRU->newbase('Prefix', $lrusize);
 
 sub load
 {
 	# untie every thing
-#	unlink $cachefn;
-	
 	if ($db) {
 		undef $db;
 		untie %pre;
 		%pre = ();
 		%prefix_loc = ();
-		untie %cache;
 	}
 
 	# tie the main prefix database
@@ -54,9 +50,7 @@ sub load
 	do "$main::data/prefix_data.pl" if !$out;
 	$out = $@ if $@;
 
-	# tie the prefix cache
-#	tie (%cache, "DB_File", $cachefn, O_RDWR|O_CREAT, 0664, $DB_HASH) or confess "can't tie prefix cache to $cachefn $!";
-	return $out;
+ 	return $out;
 }
 
 sub store
@@ -152,14 +146,14 @@ sub matchprefix
 		$matchtotal++;
 		my $s = substr($pref, 0, $i);
 		push @partials, $s;
-		my $p = $cache{$s};
+		my $p = $lru->get($s);
 		if ($p) {
 			$hits++;
 			if (isdbg('prefix')) {
 				my $percent = sprintf "%.1f", $hits * 100 / $misses;
 				dbg("Partial Prefix Cache Hit: $s Hits: $hits/$misses of $matchtotal = $percent\%");
 			}
-			$cache{$_} = $p for @partials;
+			$lru->put($_, $p) for @partials;
 			return @$p;
 		} else {
 			$misses++;
@@ -170,7 +164,7 @@ sub matchprefix
 				dbg("Partial prefix: $pref $s $part" );
 			} 
 			if (@out && $out[0] eq $s) {
-				$cache{$_} =  \@out for @partials;
+				$lru->put($_, \@out) for @partials;
 				return @out;
 			} 
 		}
@@ -194,23 +188,13 @@ sub extract
 	my @parts;
 	my ($call, $sp, $i);
 
-	# clear out the cache periodically to stop it growing for ever.
-	if ($main::systime - $lasttime >= 20*60) {
-		if (isdbg('prefix')) {
-			my $percent = sprintf "%.1f", $hits * 100 / $misses;
-			dbg("Prefix Cache Cleared, Hits: $hits/$misses of $matchtotal = $percent\%") ;
-		}
-		%cache =();
-		$lasttime = $main::systime;
-		$hits = $matchtotal = 0;
-	}
-
 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++;
-		my $p = $cache{$call};
+		$call =~ s/-\d+$//;		# ignore SSIDs
+		my $p = $lru->get($call);
 		my @nout;
 		if ($p) {
 			$hits++;
@@ -224,7 +208,7 @@ LM:	foreach $call (split /,/, $calls) {
 			@nout =  get($call);
 			if (@nout && $nout[0] eq $call) {
 				$misses++;
-				$cache{$call} = \@nout;
+				$lru->put($call, \@nout);
 				dbg("got exact prefix: $nout[0]") if isdbg('prefix');
 				push @out, @nout;
 				next;
@@ -245,7 +229,7 @@ LM:	foreach $call (split /,/, $calls) {
 			if (@nout && $nout[0] eq $s) {
 				dbg("got exact multipart prefix: $call $s") if isdbg('prefix');
 				$misses++;
-				$cache{$call} = \@nout;
+				$lru->put($call, \@nout);
 				push @out, @nout;
 				next;
 			}
@@ -265,7 +249,7 @@ LM:	foreach $call (split /,/, $calls) {
 				if (@try && $try[0] eq $s) {
 					dbg("got 3 part prefix: $call $s") if isdbg('prefix');
 					$misses++;
-					$cache{$call} = \@try;
+					$lru->put($call, \@try);
 					push @out, @try;
 					next;
 				}
@@ -288,7 +272,7 @@ LM:	foreach $call (split /,/, $calls) {
 				if (@try && $try[0] eq $s) {
 					dbg("got 2 part prefix: $call $s") if isdbg('prefix');
 					$misses++;
-					$cache{$call} = \@try;
+					$lru->put($call, \@try);
 					push @out, @try;
 					next;
 				}
@@ -304,7 +288,7 @@ LM:	foreach $call (split /,/, $calls) {
 			if (@nout) {
 				dbg("got prefix: $call = $nout[0]") if isdbg('prefix');
 				$misses++;
-				$cache{$call} = \@nout;
+				$lru->put($call, \@nout);
 				push @out, @nout;
 				next;
 			}
@@ -349,16 +333,16 @@ L1:		for ($n = 0; $n < @parts; $n++) {
 					}
 					if (@try && $try eq $try[0]) {
 						$misses++;
-						$cache{$call} = \@try;
+						$lru->put($call, \@try);
 						push @out, @try;
 					} else {
 						$misses++;
-						$cache{$call} = \@nout;
+						$lru->put($call, \@nout);
 						push @out, @nout;
 					}
 				} else {
 					$misses++;
-					$cache{$call} = \@nout;
+					$lru->put($call, \@nout);
 					push @out, @nout;
 				}
 				next LM;
@@ -368,7 +352,7 @@ L1:		for ($n = 0; $n < @parts; $n++) {
 		# we are a pirate!
 		@nout = matchprefix('Q');
 		$misses++;
-		$cache{$call} = \@nout;
+		$lru->put($call, \@nout);
 		push @out, @nout;
 	}
 	
@@ -379,6 +363,37 @@ L1:		for ($n = 0; $n < @parts; $n++) {
 	return @out;
 }
 
+#
+# turn a list of prefixes / dxcc numbers into a list of dxcc/itu/zone numbers
+#
+# nc = dxcc
+# ni = itu
+# nz = zone
+#
+
+sub to_ciz
+{
+	my $cmd = shift;
+	my @out;
+	
+	foreach my $v (@_) {
+		if ($v =~ /^\d+$/) {	
+			push @out, $v unless grep $_ eq $v, @out;
+		} else {
+			my @pre = Prefix::extract($v);
+			return () unless @pre;
+			shift @pre;
+			foreach my $p (@pre) {
+				my $n = $p->dxcc if $cmd eq 'nc' ;
+				$n = $p->itu if $cmd eq 'ni' ;
+				$n = $p->cq if $cmd eq 'nz' ;
+				push @out, $n unless grep $_ eq $n, @out;
+			}
+		}
+	}
+	return @out;
+}
+
 my %valid = (
 			 lat => '0,Latitude,slat',
 			 long => '0,Longitude,slong',