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

diff --git a/perl/Prefix.pm b/perl/Prefix.pm
index 32b1e72e..7e0eeb7a 100644
--- a/perl/Prefix.pm
+++ b/perl/Prefix.pm
@@ -13,12 +13,14 @@ 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;
 
@@ -130,6 +132,28 @@ sub next
 	return ($gotkey, @outref);
 }
 
+# 
+# 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--) {
+		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;
+	}
+	return ();
+}
+
 #
 # extract a 'prefix' from a callsign, in other words the largest entity that will
 # obtain a result from the prefix table.
@@ -146,51 +170,139 @@ sub extract
 	my @parts;
 	my ($call, $sp, $i);
   
-	foreach $call (split /,/, $calls) {
+LM:	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;
-	  
+		if (@nout && $nout[0] eq $call) {
+			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');
+				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');
+					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');
+					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 ]") if isdbg('prefix');
+				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]) {
+						push @out, @try;
+					} else {
+						push @out, @nout;
+					}
+				} else {
+					push @out, @nout;
+				}
+				next LM;
+			}
+		}
+
+		# we are a pirate!
+		push @out, matchprefix('Q');
 	}
+	
 	if (isdbg('prefix')) {
 		my $dd = new Data::Dumper([ \@out ], [qw(@out)]);
 		dbg($dd->Dumpxs);