]> scm.dxcluster.org Git - spider.git/blob - perl/Prefix.pm
I think I have most the SSID probs cracked.
[spider.git] / perl / Prefix.pm
1 #
2 # prefix handling
3 #
4 # Copyright (c) - Dirk Koopman G1TLH
5 #
6 # $Id$
7 #
8
9 package Prefix;
10
11 use Carp;
12 use DXVars;
13 use DB_File;
14 use Data::Dumper;
15 use Carp;
16
17 use strict;
18 use vars qw($db  %prefix_loc %pre);
19
20 $db;     # the DB_File handle
21 %prefix_loc;   # the meat of the info
22 %pre;       # the prefix list
23
24 sub load
25 {
26   if ($db) {
27     untie %pre;
28         %pre = ();
29         %prefix_loc = ();
30   }
31   $db = tie(%pre, "DB_File", undef, O_RDWR|O_CREAT, 0666, $DB_BTREE) or confess "can't tie \%pre ($!)";  
32   confess $@ if $@;
33   do "$main::data/prefix_data.pl";
34 #  print Data::Dumper->Dump([\%pre, \%prefix_loc], [qw(pre prefix_loc)]);
35 }
36
37 sub store
38 {
39   my ($k, $l);
40   my $fh = new FileHandle;
41   my $fn = "$main::data/prefix_data.pl";
42   
43   confess "Prefix system not started" if !$db;
44   
45   # save versions!
46   rename "$fn.oooo", "$fn.ooooo" if -e "$fn.oooo";
47   rename "$fn.ooo", "$fn.oooo" if -e "$fn.ooo";
48   rename "$fn.oo", "$fn.ooo" if -e "$fn.oo";
49   rename "$fn.o", "$fn.oo" if -e "$fn.o";
50   rename "$fn", "$fn.o" if -e "$fn";
51   
52   $fh->open(">$fn") or die "Can't open $fn ($!)";
53
54   # prefix location data
55   $fh->print("%prefix_loc = (\n");
56   foreach $l (sort {$a <=> $b} keys %prefix_loc) {
57     my $r = $prefix_loc{$l};
58         $fh->printf("   $l => bless( { name => '%s', dxcc => %d, itu => %d, utcoff => %d, lat => %f, long => %f }, 'Prefix'),\n",
59                     $r->{name}, $r->{dxcc}, $r->{itu}, $r->{cq}, $r->{utcoff}, $r->{lat}, $r->{long});
60   }
61   $fh->print(");\n\n");
62
63   # prefix data
64   $fh->print("%pre = (\n");
65   foreach $k (sort keys %pre) {
66     $fh->print("   '$k' => [");
67         my @list = @{$pre{$k}};
68         my $l;
69         my $str;
70         foreach $l (@list) {
71       $str .= " $l,";
72     }
73         chop $str;  
74         $fh->print("$str ],\n");
75   }
76   $fh->print(");\n");
77   $fh->close;
78 }
79
80 # what you get is a list that looks like:-
81
82 # prefix => @list of blessed references to prefix_locs 
83 #
84 # This routine will only do what you ask for, if you wish to be intelligent
85 # then that is YOUR problem!
86 #
87 sub get
88 {
89   my $key = shift;
90   my @out;
91   my @outref;
92   my $ref;
93   my $gotkey;
94   
95   $gotkey = $key;
96   return () if $db->seq($gotkey, $ref, R_CURSOR);
97   return () if $key ne substr $gotkey, 0, length $key;
98
99   @outref = map { $prefix_loc{$_} } split ',', $ref;
100   return ($gotkey, @outref);
101 }
102
103 #
104 # get the next key that matches, this assumes that you have done a 'get' first
105 #
106
107 sub next
108 {
109   my $key = shift;
110   my @out;
111   my @outref;
112   my $ref;
113   my $gotkey;
114   
115   return () if $db->seq($gotkey, $ref, R_NEXT);
116   return () if $key ne substr $gotkey, 0, length $key;
117   
118   @outref = map { $prefix_loc{$_} } split ',', $ref;
119   return ($gotkey, @outref);
120 }
121
122 #
123 # extract a 'prefix' from a callsign, in other words the largest entity that will
124 # obtain a result from the prefix table.
125 #
126 # This is done by repeated probing, callsigns of the type VO1/G1TLH or
127 # G1TLH/VO1 (should) return VO1
128 #
129
130 sub extract
131 {
132   my $call = uc shift;
133   my @out;
134   my @nout;
135   my $p;
136   my @parts;
137   my ($sp, $i);
138   
139   # first check if the whole thing succeeds
140   @out = get($call);
141   return @out if @out > 0 && $out[0] eq $call;
142   
143   # now split the call into parts if required
144   @parts = ($call =~ '/') ? split('/', $call) : ($call);
145
146   # remove any /0-9 /P /A /M /MM /AM suffixes etc
147   if (@parts > 1) {
148     $p = $parts[$#parts];
149         pop @parts if $p =~ /^(\d+|[PABM]|AM|MM|BCN|SIX|Q\w+)$/o;
150     $p = $parts[$#parts];
151         pop @parts if $p =~ /^(\d+|[PABM]|AM|MM|BCN|SIX|Q\w+)$/o;
152   
153     # can we resolve them by direct lookup
154         foreach $p (@parts) {
155       @out = get($p);
156           return @out if @out > 0 && $out[0] eq $call;
157         }
158   }
159   
160   # which is the shortest part (first if equal)?
161   $sp = $parts[0];
162   foreach $p (@parts) {
163     $sp = $p if length $sp > length $p;
164   }
165   # now start to resolve it from the left hand end
166   for (@out = (), $i = 1; $i <= length $sp; ++$i) {
167     @nout = get(substr($sp, 0, $i));
168         last if @nout > 0 && $nout[0] gt $sp;
169         last if @nout == 0;
170         @out = @nout;
171   }
172   
173   # not found
174   return (@out > 0) ? @out : ();
175 }
176
177 my %valid = (
178   lat => '0,Latitude,slat',
179   long => '0,Longitude,slong',
180   dxcc => '0,DXCC',
181   name => '0,Name',
182   itu => '0,ITU',
183   cq => '0,CQ',
184   utcoff => '0,UTC offset',
185 );
186
187 no strict;
188 sub AUTOLOAD
189 {
190   my $self = shift;
191   my $name = $AUTOLOAD;
192   
193   return if $name =~ /::DESTROY$/;
194   $name =~ s/.*:://o;
195   
196   confess "Non-existant field '$AUTOLOAD'" if !$valid{$name};
197   if (@_) {
198     $self->{$name} = shift;
199   }
200   return $self->{$name};
201 }
202 use strict;
203
204 #
205 # return a prompt for a field
206 #
207
208 sub field_prompt
209
210   my ($self, $ele) = @_;
211   return $valid{$ele};
212 }
213 1;
214
215 __END__