X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FPrefix.pm;h=5b223e9f37af092c788e2ec8e95f8a558eddf597;hb=f8bcb6f0239cfcec6d31a37b08c7f7e28cbf7628;hp=32b1e72ec0ec65c57ae4ba4218c3b163b394a8b1;hpb=da7476ca7af0722de0cab439f6f4eea3d767daf4;p=spider.git

diff --git a/perl/Prefix.pm b/perl/Prefix.pm
index 32b1e72e..5b223e9f 100644
--- a/perl/Prefix.pm
+++ b/perl/Prefix.pm
@@ -13,20 +13,25 @@ use DXVars;
 use DB_File;
 use Data::Dumper;
 use DXDebug;
+use DXUtil;
+
 
 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;
+$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 $lasttime $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 = $matchtotal = 1;		# cache stats
 
 sub load
 {
@@ -95,20 +100,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);
 }
 
 #
@@ -118,16 +119,49 @@ 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);
+}
+
+# 
+# search for the nearest match of a prefix string (starting
+# from the RH end of the string passed)
+#
+
+sub matchprefix
+{
+	my $pref = shift;
+
+	for (my $i = length $pref; $i; $i--) {
+		$matchtotal++;
+		my $s = substr($pref, 0, $i);
+		my $p = $cache{$s};
+		if ($p) {
+			$hits++;
+			if (isdbg('prefix')) {
+				my $percent = $hits * 100 / $matchtotal;
+				dbg("Partial Prefix Cache Hit: $s Hits: $hits of $matchtotal = $percent\%");
+			}
+			return @$p;
+		} else {
+			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{$s} = \@out;
+				return @out;
+			}
+		}
+	}
+	return ();
 }
 
 #
@@ -146,51 +180,177 @@ sub extract
 	my @parts;
 	my ($call, $sp, $i);
   
-	foreach $call (split /,/, $calls) {
-		# first check if the whole thing succeeds
-		my @nout = get($call);
-		push @out, @nout if @nout;
-		next if @nout > 0 && $nout[0] eq $call;
-	  
+	# clear out the cache periodically to stop it growing for ever.
+	if ($main::systime - $lasttime >= 15*60) {
+		if (isdbg('prefix')) {
+			my $percent = $hits * 100 / $matchtotal;
+			dbg("Prefix Cache Cleared, Hits: $hits of $matchtotal = $percent\%") ;
+		}
+		my $percent = $hits * 100 / $matchtotal;
+		dbg("Prefix Cache Cleared, $percent\% hits") if isdbg('prefix');
+		%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};
+		my @nout;
+		if ($p) {
+			$hits++;
+			if (isdbg('prefix')) {
+				my $percent = $hits * 100 / $matchtotal;
+				dbg("Prefix Cache Hit: $call Hits: $hits of $matchtotal = $percent\%");
+			}
+			push @out, @$p;
+			next;
+		} else {
+			@nout =  get($call);
+			if (@nout && $nout[0] eq $call) {
+				$cache{$call} = \@nout;
+				dbg("got exact prefix: $nout[0]") if isdbg('prefix');
+				push @out, @nout;
+				next;
+			}
+		}
+
 		# now split the call into parts if required
 		@parts = ($call =~ '/') ? split('/', $call) : ($call);
+		dbg("Parts: $call = " . join(' ', @parts))	if isdbg('prefix');
 
 		# remove any /0-9 /P /A /M /MM /AM suffixes etc
 		if (@parts > 1) {
-			$p = $parts[0];
-			shift @parts if $p =~ /^(WEB|NET)$/o;
-			$p = $parts[$#parts];
-			pop @parts if $p =~ /^(\d+|[JPABM]|AM|MM|BCN|JOTA|SIX|WEB|NET|Q\w+)$/o;
-			$p = $parts[$#parts];
-			pop @parts if $p =~ /^(\d+|[JPABM]|AM|MM|BCN|JOTA|SIX|WEB|NET|Q\w+)$/o;
-	  
+			@parts = grep { !/^\d+$/ && !/^[PABM]$/ && !/^(?:|AM|MM|BCN|JOTA|SIX|WEB|NET|Q\w+)$/; } @parts;
+
 			# can we resolve them by direct lookup
-			foreach $p (@parts) {
-				@nout = get($p);
-				push @out, @nout if @nout;
-				next if @nout > 0 && $nout[0] eq $call;
+			my $s = join('/', @parts); 
+			@nout = get($s);
+			if (@nout && $nout[0] eq $s) {
+				dbg("got exact multipart prefix: $call $s") if isdbg('prefix');
+				$cache{$call} = \@nout;
+				push @out, @nout;
+				next;
 			}
 		}
+		dbg("Parts now: $call = " . join(' ', @parts))	if isdbg('prefix');
   
-		# which is the shortest part (first if equal)?
-		dbg("Parts: $call = " . join('|', @parts))	if isdbg('prefix');
-		$sp = $parts[0];
-		foreach $p (@parts) {
-			$sp = $p if length $p < length $sp;
+		# at this point we should have two or three parts
+		# if it is three parts then join the first and last parts together
+		# to get an answer
+
+		# first deal with prefix/x00xx/single letter things
+		if (@parts == 3 && length $parts[0] <= length $parts[1]) {
+			@nout = matchprefix($parts[0]);
+			if (@nout) {
+				my $s = join('/', $nout[0], $parts[2]);
+				my @try = get($s);
+				if (@try && $try[0] eq $s) {
+					dbg("got 3 part prefix: $call $s") if isdbg('prefix');
+					$cache{$call} = \@try;
+					push @out, @try;
+					next;
+				}
+				
+				# if the second part is a callsign and the last part is one letter
+				if (is_callsign($parts[1]) && length $parts[2] == 1) {
+					pop @parts;
+				}
+			}
 		}
-		$sp =~ s/-\d+$//;     # remove any SSID
-		
-#		# now start to resolve it from the left hand end
-#		for ($i = 1; $i <= length $sp; ++$i) {
-		# now start to resolve it from the right hand end
-		for ($i = length $sp; $i >= 1; --$i) {
-			my @wout = get(substr($sp, 0, $i));
-			next if @wout > 0 && $wout[0] gt $sp;
-#			last if @wout == 0;
-			push @out, @wout;
-			last if @wout;
+
+		# if it is a two parter 
+		if (@parts == 2) {
+
+			# try it as it is as compound, taking the first part as the prefix
+			@nout = matchprefix($parts[0]);
+			if (@nout) {
+				my $s = join('/', $nout[0], $parts[1]);
+				my @try = get($s);
+				if (@try && $try[0] eq $s) {
+					dbg("got 2 part prefix: $call $s") if isdbg('prefix');
+					$cache{$call} = \@try;
+					push @out, @try;
+					next;
+				}
+			}
 		}
+
+		# remove the problematic /J suffix
+		pop @parts if @parts > 1 && $parts[$#parts] eq 'J';
+
+		# single parter
+		if (@parts == 1) {
+			@nout = matchprefix($parts[0]);
+			if (@nout) {
+				dbg("got prefix: $call = $nout[0]") if isdbg('prefix');
+				$cache{$call} = \@nout;
+				push @out, @nout;
+				next;
+			}
+		}
+
+		# try ALL the parts
+        my @checked;
+		my $n;
+L1:		for ($n = 0; $n < @parts; $n++) {
+			my $sp = '';
+			my ($k, $i);
+			for ($i = $k = 0; $i < @parts; $i++) {
+				next if $checked[$i];
+				my $p = $parts[$i];
+				if (!$sp || length $p < length $sp) {
+					dbg("try part: $p") if isdbg('prefix');
+					$k = $i;
+					$sp = $p;
+				}
+			}
+			$checked[$k] = 1;
+			$sp =~ s/-\d+$//;     # remove any SSID
+			
+			# now start to resolve it from the right hand end
+			@nout = matchprefix($sp);
+			
+			# try and search for it in the descriptions as
+			# a whole callsign if it has multiple parts and the output
+			# is more two long, this should catch things like
+			# FR5DX/T without having to explicitly stick it into
+			# the prefix table.
+			
+			if (@nout) {
+				if (@parts > 1) {
+					$parts[$k] = $nout[0];
+					my $try = join('/', @parts);
+					my @try = get($try);
+					if (isdbg('prefix')) {
+						my $part = $try[0] || "*";
+						$part .= '*' unless $part eq '*' || $part eq $try;
+						dbg("Compound prefix: $try $part" );
+					}
+					if (@try && $try eq $try[0]) {
+						$cache{$call} = \@try;
+						push @out, @try;
+					} else {
+						$cache{$call} = \@nout;
+						push @out, @nout;
+					}
+				} else {
+					$cache{$call} = \@nout;
+					push @out, @nout;
+				}
+				next LM;
+			}
+		}
+
+		# we are a pirate!
+		@nout = matchprefix('Q');
+		$cache{$call} = \@nout;
+		push @out, @nout;
 	}
+	
 	if (isdbg('prefix')) {
 		my $dd = new Data::Dumper([ \@out ], [qw(@out)]);
 		dbg($dd->Dumpxs);