X-Git-Url: http://dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FPrefix.pm;h=7e0eeb7a7c38538128c9f78e2367d293b37f09a2;hb=dbf7523a9b228dbdf1d03109afde351b8b194fab;hp=8ea62b87fbda9e742fd0a481b925e753a9b2c65e;hpb=ca18864d1264fadfe9869b630f05c950876c2169;p=spider.git diff --git a/perl/Prefix.pm b/perl/Prefix.pm index 8ea62b87..7e0eeb7a 100644 --- a/perl/Prefix.pm +++ b/perl/Prefix.pm @@ -8,13 +8,22 @@ package Prefix; -use Carp; +use IO::File; use DXVars; use DB_File; use Data::Dumper; -use Carp; +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,0)); +$main::build += $VERSION; +$main::branch += $BRANCH; + use vars qw($db %prefix_loc %pre); $db = undef; # the DB_File handle @@ -40,7 +49,7 @@ sub load sub store { my ($k, $l); - my $fh = new FileHandle; + my $fh = new IO::File; my $fn = "$main::data/prefix_data.pl"; confess "Prefix system not started" if !$db; @@ -123,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. @@ -133,49 +164,150 @@ sub next sub extract { - my $call = uc shift; + my $calls = uc shift; my @out; - my @nout; my $p; my @parts; - my ($sp, $i); - - # first check if the whole thing succeeds - @out = get($call); - return @out if @out > 0 && $out[0] eq $call; + my ($call, $sp, $i); - # now split the call into parts if required - @parts = ($call =~ '/') ? split('/', $call) : ($call); - - # remove any /0-9 /P /A /M /MM /AM suffixes etc - if (@parts > 1) { - $p = $parts[$#parts]; - pop @parts if $p =~ /^(\d+|[PABM]|AM|MM|BCN|SIX|Q\w+)$/o; - $p = $parts[$#parts]; - pop @parts if $p =~ /^(\d+|[PABM]|AM|MM|BCN|SIX|Q\w+)$/o; - - # can we resolve them by direct lookup - foreach $p (@parts) { - @out = get($p); - return @out if @out > 0 && $out[0] eq $call; +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; + 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) { + @parts = grep { !/^\d+$/ && !/^[PABM]$/ && !/^(?:|AM|MM|BCN|JOTA|SIX|WEB|NET|Q\w+)$/; } @parts; + + # can we resolve them by direct lookup + 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)? - $sp = $parts[0]; - foreach $p (@parts) { - $sp = $p if length $sp > length $p; + # 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; + } + } + } + + # 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'); } - # now start to resolve it from the left hand end - for (@out = (), $i = 1; $i <= length $sp; ++$i) { - @nout = get(substr($sp, 0, $i)); - last if @nout > 0 && $nout[0] gt $sp; - last if @nout == 0; - @out = @nout; + + if (isdbg('prefix')) { + my $dd = new Data::Dumper([ \@out ], [qw(@out)]); + dbg($dd->Dumpxs); } - - # not found - return (@out > 0) ? @out : (); + return @out; } my %valid = ( @@ -186,6 +318,7 @@ my %valid = ( itu => '0,ITU', cq => '0,CQ', utcoff => '0,UTC offset', + cont => '0,Continent', ); no strict; @@ -198,6 +331,9 @@ sub AUTOLOAD $name =~ s/.*:://o; confess "Non-existant field '$AUTOLOAD'" if !$valid{$name}; + # this clever line of code creates a subroutine which takes over from autoload + # from OO Perl - Conway + *{$AUTOLOAD} = sub {@_ > 1 ? $_[0]->{$name} = $_[1] : $_[0]->{$name}} ; if (@_) { $self->{$name} = shift; }