]> scm.dxcluster.org Git - spider.git/blob - perl/USDB.pm
fix weird sprintf error in AnnTalk dbging
[spider.git] / perl / USDB.pm
1 #
2 # Package to handle US Callsign -> City, State translations
3 #
4 # Copyright (c) 2002 Dirk Koopman G1TLH
5 #
6
7
8 package USDB;
9
10 use strict;
11
12 use DXVars;
13 use DB_File;
14 use File::Copy;
15 use DXDebug;
16 use DXUtil;
17
18 #use Compress::Zlib;
19
20 use vars qw(%db $present $dbfn);
21
22 localdata_mv("usdb.v1");
23 $dbfn = localdata("usdb.v1");
24
25 sub init
26 {
27         end();
28         if (tie %db, 'DB_File', $dbfn, O_RDWR, 0664, $DB_BTREE) {
29                 $present = 1;
30                 return "US Database loaded";
31         }
32         return "US Database not loaded";
33 }
34
35 sub end
36 {
37         return unless $present;
38         untie %db;
39         undef $present;
40 }
41
42 sub get
43 {
44         return () unless $present;
45         my $ctyn = $db{$_[0]};
46         my @s = split /\|/, $db{$ctyn} if $ctyn;
47         return @s;
48 }
49
50 sub _add
51 {
52         my ($db, $call, $city, $state) = @_;
53         
54         # lookup the city 
55         my $s = uc "$city|$state";
56         my $ctyn = $db->{$s};
57         unless ($ctyn) {
58                 my $no = $db->{'##'} || 1;
59                 $ctyn = "#$no";
60                 $db->{$s} = $ctyn;
61                 $db->{$ctyn} = $s; 
62                 $no++;
63                 $db->{'##'} = "$no";
64         }
65         $db->{uc $call} = $ctyn; 
66 }
67
68 sub add
69 {
70         _add(\%db, @_);
71 }
72
73 sub getstate
74 {
75         return () unless $present;
76         my @s = get($_[0]);
77         return @s ? $s[1] : undef;
78 }
79
80 sub getcity
81 {
82         return () unless $present;
83         my @s = get($_[0]);
84         return @s ? $s[0] : undef;
85 }
86
87 sub del
88 {
89         my $call = uc shift;
90         delete $db{$call};
91 }
92
93 #
94 # load in / update an existing DB with a standard format (GZIPPED)
95 # "raw" file.
96 #
97 # Note that this removes and overwrites the existing DB file
98 # You will need to init again after doing this
99
100
101 sub load
102 {
103         return "Need a filename" unless @_;
104         
105         # create the new output file
106         my $a = new DB_File::BTREEINFO;
107         $a->{psize} = 4096 * 2;
108         my $s = 0;
109
110         # guess a cache size
111         for (@_) {
112                 my $ts = -s;
113                 $s = $ts if $ts > $s;
114         }
115         if ($s > 1024 * 1024) {
116                 $a->{cachesize} = int($s / (1024*1024)) * 3 * 1024 * 1024;
117         }
118
119 #       print "cache size " . $a->{cachesize} . "\n";
120         
121         my %dbn;
122         if (-e $dbfn ) {
123                 copy($dbfn, "$dbfn.new") or return "cannot copy $dbfn -> $dbfn.new $!";
124         }
125         
126         tie %dbn, 'DB_File', "$dbfn.new", O_RDWR|O_CREAT, 0664, $a or return "cannot tie $dbfn.new $!";
127         
128         # now write away all the files
129         my $count = 0;
130         for (@_) {
131                 my $ofn = shift;
132
133                 return "Cannot find $ofn" unless -r $ofn;
134                 
135                 # conditionally handle compressed files (don't cha just lurv live code, this is
136                 # a rave from the grave and is "in memoriam Flossie" the ICT 1301G I learnt on.
137                 # {for pedant computer historians a 1301G is an ICT 1301A that has been 
138                 # Galdorised[tm] (for instance had decent IOs and a 24 pre-modify instruction)}
139                 my $nfn = $ofn;
140                 if ($nfn =~ /.gz$/i) {
141                         my $gz;
142                         eval qq{use Compress::Zlib; \$gz = gzopen(\$ofn, "rb")};
143                         return "Cannot read compressed files $@ $!" if $@ || !$gz;
144                         $nfn =~ s/.gz$//i;
145                         my $of = new IO::File ">$nfn" or return "Cannot write to $nfn $!";
146                         my ($l, $buf);
147                         $of->write($buf, $l) while ($l = $gz->gzread($buf));
148                         $gz->gzclose;
149                         $of->close;
150                         $ofn = $nfn;
151                 }
152
153                 my $of = new IO::File "$ofn" or return "Cannot read $ofn $!";
154
155                 while (<$of>) {
156                         my $l = $_;
157                         $l =~ s/[\r\n]+$//;
158                         my ($call, $city, $state) = split /\|/, $l;
159
160                         _add(\%dbn, $call, $city, $state);
161                         
162                         $count++;
163                 }
164                 $of->close;
165                 unlink $nfn;
166         }
167         
168         untie %dbn;
169         rename "$dbfn.new", $dbfn;
170         return "$count records";
171 }
172
173 1;