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:-
#
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);
}
#
#
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);
}
#
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;
sub field_prompt
{
- my ($self, $ele) = @_;
- return $valid{$ele};
+ my ($self, $ele) = @_;
+ return $valid{$ele};
}
1;
projects / spider.git / blobdiff