X-Git-Url: http://www.dxcluster.org/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl%2FPrefix.pm;h=ba9ea2b93c1f91fa5a4530f7ba6f4025a7c6d667;hb=d5b4190c36f130852973121042876af3c5642cd7;hp=cab54cd80b1f32c1ed46367c7eb609c477cbf358;hpb=4c0591c17b89dbb049ba119d3f3ea15c5b56128c;p=spider.git diff --git a/perl/Prefix.pm b/perl/Prefix.pm index cab54cd8..ba9ea2b9 100644 --- a/perl/Prefix.pm +++ b/perl/Prefix.pm @@ -17,66 +17,66 @@ use Carp; use strict; use vars qw($db %prefix_loc %pre); -$db = undef; # the DB_File handle -%prefix_loc = (); # the meat of the info -%pre = (); # the prefix list +$db = undef; # the DB_File handle +%prefix_loc = (); # the meat of the info +%pre = (); # the prefix list sub load { - if ($db) { - untie %pre; - %pre = (); - %prefix_loc = (); - } - $db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0666, $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)]); - return $out; + if ($db) { + untie %pre; + %pre = (); + %prefix_loc = (); + } + $db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0666, $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)]); + return $out; } sub store { - my ($k, $l); - my $fh = new FileHandle; - my $fn = "$main::data/prefix_data.pl"; + my ($k, $l); + my $fh = new FileHandle; + my $fn = "$main::data/prefix_data.pl"; - confess "Prefix system not started" if !$db; + confess "Prefix system not started" if !$db; - # save versions! - rename "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo"; - rename "$fn.ooo", "$fn.oooo" if -e "$fn.ooo"; - rename "$fn.oo", "$fn.ooo" if -e "$fn.oo"; - rename "$fn.o", "$fn.oo" if -e "$fn.o"; - rename "$fn", "$fn.o" if -e "$fn"; + # save versions! + rename "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo"; + rename "$fn.ooo", "$fn.oooo" if -e "$fn.ooo"; + rename "$fn.oo", "$fn.ooo" if -e "$fn.oo"; + rename "$fn.o", "$fn.oo" if -e "$fn.o"; + rename "$fn", "$fn.o" if -e "$fn"; - $fh->open(">$fn") or die "Can't open $fn ($!)"; - - # prefix location data - $fh->print("%prefix_loc = (\n"); - foreach $l (sort {$a <=> $b} keys %prefix_loc) { - my $r = $prefix_loc{$l}; - $fh->printf(" $l => bless( { name => '%s', dxcc => %d, itu => %d, utcoff => %d, lat => %f, long => %f }, 'Prefix'),\n", - $r->{name}, $r->{dxcc}, $r->{itu}, $r->{cq}, $r->{utcoff}, $r->{lat}, $r->{long}); - } - $fh->print(");\n\n"); - - # prefix data - $fh->print("%pre = (\n"); - foreach $k (sort keys %pre) { - $fh->print(" '$k' => ["); - my @list = @{$pre{$k}}; - my $l; - my $str; - foreach $l (@list) { - $str .= " $l,"; - } - chop $str; - $fh->print("$str ],\n"); - } - $fh->print(");\n"); - $fh->close; + $fh->open(">$fn") or die "Can't open $fn ($!)"; + + # prefix location data + $fh->print("%prefix_loc = (\n"); + foreach $l (sort {$a <=> $b} keys %prefix_loc) { + my $r = $prefix_loc{$l}; + $fh->printf(" $l => bless( { name => '%s', dxcc => %d, itu => %d, utcoff => %d, lat => %f, long => %f }, 'Prefix'),\n", + $r->{name}, $r->{dxcc}, $r->{itu}, $r->{cq}, $r->{utcoff}, $r->{lat}, $r->{long}); + } + $fh->print(");\n\n"); + + # prefix data + $fh->print("%pre = (\n"); + foreach $k (sort keys %pre) { + $fh->print(" '$k' => ["); + my @list = @{$pre{$k}}; + my $l; + my $str; + foreach $l (@list) { + $str .= " $l,"; + } + chop $str; + $fh->print("$str ],\n"); + } + $fh->print(");\n"); + $fh->close; } # what you get is a list that looks like:- @@ -88,18 +88,18 @@ sub store # sub get { - my $key = shift; - my @out; - my @outref; - my $ref; - my $gotkey; + my $key = shift; + my @out; + my @outref; + my $ref; + my $gotkey; - $gotkey = $key; - return () if $db->seq($gotkey, $ref, R_CURSOR); - return () if $key ne substr $gotkey, 0, length $key; + $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); + @outref = map { $prefix_loc{$_} } split ',', $ref; + return ($gotkey, @outref); } # @@ -108,17 +108,17 @@ sub get # sub next { - my $key = shift; - my @out; - my @outref; - my $ref; - my $gotkey; + 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; + 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); + @outref = map { $prefix_loc{$_} } split ',', $ref; + return ($gotkey, @outref); } # @@ -131,75 +131,75 @@ sub next sub extract { - my $call = uc shift; - my @out; - my @nout; - my $p; - my @parts; - my ($sp, $i); + my $call = 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; + # first check if the whole thing succeeds + @out = get($call); + return @out if @out > 0 && $out[0] eq $call; - # 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; + # 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; + # can we resolve them by direct lookup + foreach $p (@parts) { + @out = get($p); + return @out if @out > 0 && $out[0] eq $call; + } } - } - # which is the shortest part (first if equal)? - $sp = $parts[0]; - foreach $p (@parts) { - $sp = $p if length $sp > length $p; - } - # 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; - } + # which is the shortest part (first if equal)? + $sp = $parts[0]; + foreach $p (@parts) { + $sp = $p if length $sp > length $p; + } + # 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; + } - # not found - return (@out > 0) ? @out : (); + # not found + return (@out > 0) ? @out : (); } my %valid = ( - lat => '0,Latitude,slat', - long => '0,Longitude,slong', - dxcc => '0,DXCC', - name => '0,Name', - itu => '0,ITU', - cq => '0,CQ', - utcoff => '0,UTC offset', -); + lat => '0,Latitude,slat', + long => '0,Longitude,slong', + dxcc => '0,DXCC', + name => '0,Name', + itu => '0,ITU', + cq => '0,CQ', + utcoff => '0,UTC offset', + ); no strict; sub AUTOLOAD { - my $self = shift; - my $name = $AUTOLOAD; + my $self = shift; + my $name = $AUTOLOAD; - return if $name =~ /::DESTROY$/; - $name =~ s/.*:://o; + return if $name =~ /::DESTROY$/; + $name =~ s/.*:://o; - confess "Non-existant field '$AUTOLOAD'" if !$valid{$name}; - if (@_) { - $self->{$name} = shift; - } - return $self->{$name}; + confess "Non-existant field '$AUTOLOAD'" if !$valid{$name}; + if (@_) { + $self->{$name} = shift; + } + return $self->{$name}; } use strict; @@ -209,8 +209,8 @@ use strict; sub field_prompt { - my ($self, $ele) = @_; - return $valid{$ele}; + my ($self, $ele) = @_; + return $valid{$ele}; } 1;