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