X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FPrefix.pm;h=3fdcdceaf8aa1823b43dedd01d3cbfb297fc28d0;hb=d80e548735a53ddf74561e54956ddf94116608d0;hp=7e0eeb7a7c38538128c9f78e2367d293b37f09a2;hpb=dbf7523a9b228dbdf1d03109afde351b8b194fab;p=spider.git

diff --git a/perl/Prefix.pm b/perl/Prefix.pm
index 7e0eeb7a..3fdcdcea 100644
--- a/perl/Prefix.pm
+++ b/perl/Prefix.pm
@@ -24,25 +24,38 @@ $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);
+use vars qw($db  %prefix_loc %pre %cache $misses $hits $matchtotal $lasttime);
 
 $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
+
+#my $cachefn = "$main::data/prefix_cache";
 
 sub load
 {
+	# untie every thing
+#	unlink $cachefn;
+	
 	if ($db) {
 		undef $db;
 		untie %pre;
 		%pre = ();
 		%prefix_loc = ();
+		untie %cache;
 	}
-	$db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0666, $DB_BTREE) or confess "can't tie \%pre ($!)";  
+
+	# 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 $@;
-	#  print Data::Dumper->Dump([\%pre, \%prefix_loc], [qw(pre prefix_loc)]);
+
+	# 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;
 }
 
@@ -97,20 +110,16 @@ sub store
 # This routine will only do what you ask for, if you wish to be intelligent
 # then that is YOUR problem!
 #
+
 sub get
 {
 	my $key = shift;
-	my @out;
-	my @outref;
 	my $ref;
-	my $gotkey;
-  
-	$gotkey = $key;
+	my $gotkey = $key;
 	return () if $db->seq($gotkey, $ref, R_CURSOR);
 	return () if $key ne substr $gotkey, 0, length $key;
 
-	@outref = map { $prefix_loc{$_} } split ',', $ref;
-	return ($gotkey, @outref);
+	return ($gotkey,  map { $prefix_loc{$_} } split ',', $ref);
 }
 
 #
@@ -120,16 +129,13 @@ sub get
 sub next
 {
 	my $key = shift;
-	my @out;
-	my @outref;
 	my $ref;
 	my $gotkey;
   
 	return () if $db->seq($gotkey, $ref, R_NEXT);
 	return () if $key ne substr $gotkey, 0, length $key;
   
-	@outref = map { $prefix_loc{$_} } split ',', $ref;
-	return ($gotkey, @outref);
+	return ($gotkey, map { $prefix_loc{$_} } split ',', $ref);
 }
 
 # 
@@ -140,16 +146,34 @@ sub next
 sub matchprefix
 {
 	my $pref = shift;
+	my @partials;
 
+	$pref =~ s/-\d+$//;
 	for (my $i = length $pref; $i; $i--) {
+		$matchtotal++;
 		my $s = substr($pref, 0, $i);
-		my @out = get($s);
-		if (isdbg('prefix')) {
-			my $part = $out[0] || "*";
-			$part .= '*' unless $part eq '*' || $part eq $s;
-			dbg("Partial prefix: $pref $s $part" );
-		} 
-		return @out if @out && $out[0] eq $s;
+		my $p = $cache{$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\%");
+			}
+			return @$p;
+		} else {
+			$misses++;
+			push @partials, $s;
+			my @out = get($s);
+			if (isdbg('prefix')) {
+				my $part = $out[0] || "*";
+				$part .= '*' unless $part eq '*' || $part eq $s;
+				dbg("Partial prefix: $pref $s $part" );
+			} 
+			if (@out && $out[0] eq $s) {
+				$cache{$_} =  \@out for @partials;
+				return @out;
+			} 
+		}
 	}
 	return ();
 }
@@ -169,14 +193,42 @@ sub extract
 	my $p;
 	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
-		my @nout = get($call);
-		if (@nout && $nout[0] eq $call) {
-			dbg("got exact prefix: $nout[0]") if isdbg('prefix');
-			push @out, @nout;
+
+		# 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};
+		my @nout;
+		if ($p) {
+			$hits++;
+			if (isdbg('prefix')) {
+				my $percent = sprintf "%.1f", $hits * 100 / $misses;
+				dbg("Prefix Cache Hit: $call Hits: $hits/$misses of $matchtotal = $percent\%");
+			}
+			push @out, @$p;
 			next;
+		} else {
+			@nout =  get($call);
+			if (@nout && $nout[0] eq $call) {
+				$misses++;
+				$cache{$call} = \@nout;
+				dbg("got exact prefix: $nout[0]") if isdbg('prefix');
+				push @out, @nout;
+				next;
+			}
 		}
 
 		# now split the call into parts if required
@@ -192,6 +244,8 @@ LM:	foreach $call (split /,/, $calls) {
 			@nout = get($s);
 			if (@nout && $nout[0] eq $s) {
 				dbg("got exact multipart prefix: $call $s") if isdbg('prefix');
+				$misses++;
+				$cache{$call} = \@nout;
 				push @out, @nout;
 				next;
 			}
@@ -210,6 +264,8 @@ LM:	foreach $call (split /,/, $calls) {
 				my @try = get($s);
 				if (@try && $try[0] eq $s) {
 					dbg("got 3 part prefix: $call $s") if isdbg('prefix');
+					$misses++;
+					$cache{$call} = \@try;
 					push @out, @try;
 					next;
 				}
@@ -231,6 +287,8 @@ LM:	foreach $call (split /,/, $calls) {
 				my @try = get($s);
 				if (@try && $try[0] eq $s) {
 					dbg("got 2 part prefix: $call $s") if isdbg('prefix');
+					$misses++;
+					$cache{$call} = \@try;
 					push @out, @try;
 					next;
 				}
@@ -244,7 +302,9 @@ LM:	foreach $call (split /,/, $calls) {
 		if (@parts == 1) {
 			@nout = matchprefix($parts[0]);
 			if (@nout) {
-				dbg("got prefix: $call ]") if isdbg('prefix');
+				dbg("got prefix: $call = $nout[0]") if isdbg('prefix');
+				$misses++;
+				$cache{$call} = \@nout;
 				push @out, @nout;
 				next;
 			}
@@ -288,11 +348,17 @@ L1:		for ($n = 0; $n < @parts; $n++) {
 						dbg("Compound prefix: $try $part" );
 					}
 					if (@try && $try eq $try[0]) {
+						$misses++;
+						$cache{$call} = \@try;
 						push @out, @try;
 					} else {
+						$misses++;
+						$cache{$call} = \@nout;
 						push @out, @nout;
 					}
 				} else {
+					$misses++;
+					$cache{$call} = \@nout;
 					push @out, @nout;
 				}
 				next LM;
@@ -300,10 +366,13 @@ L1:		for ($n = 0; $n < @parts; $n++) {
 		}
 
 		# we are a pirate!
-		push @out, matchprefix('Q');
+		@nout = matchprefix('Q');
+		$misses++;
+		$cache{$call} = \@nout;
+		push @out, @nout;
 	}
 	
-	if (isdbg('prefix')) {
+	if (isdbg('prefixdata')) {
 		my $dd = new Data::Dumper([ \@out ], [qw(@out)]);
 		dbg($dd->Dumpxs);
 	}