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