]> dxcluster.org Git - spider.git/blob - perl/create_prefix.pl
add ak1a compat changes to chat
[spider.git] / perl / create_prefix.pl
1 #!/usr/bin/perl
2 # a program to create a prefix file from a wpxloc.raw file
3 #
4 # Copyright (c) - Dirk Koopman G1TLH
5 #
6 # $Id$
7 #
8
9 require 5.004;
10
11 # search local then perl directories
12 BEGIN {
13         # root of directory tree for this system
14         $root = "/spider"; 
15         $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
16         
17         unshift @INC, "$root/perl";     # this IS the right way round!
18         unshift @INC, "$root/local";
19 }
20
21 use DXVars;
22 use Data::Dumper;
23 use strict;
24
25 my %loc = ();                                           # the location unique hash
26 my $nextloc = 1;                                        # the next location number
27 my %locn = ();                                          # the inverse of the above
28 my %pre = ();                                           # the prefix hash
29 my %pren = ();                                          # the inverse
30
31 # open the input file
32 my $ifn = $ARGV[0] if $ARGV[0];
33 $ifn = "$main::data/wpxloc.raw" if !$ifn;
34 open (IN, $ifn) or die "can't open $ifn ($!)";
35
36 # first pass, find all the 'master' location records
37 while (<IN>) {
38         next if /^\!/;                          # ignore comment lines
39         chomp;
40         my @f  = split;                         # get each 'word'
41         next if @f == 0;                        # ignore blank lines
42
43         if (($f[14] && $f[14] eq '@') || ($f[15] && $f[15] eq '@')) {
44                 my $locstr = join ' ', @f[1..13];
45                 my $loc = $loc{$locstr};
46                 $loc = addloc($locstr) if !$loc;
47         }
48 }
49
50 #foreach $loc (sort {$a <=> $b;} keys %locn) {
51 #  print "loc: $loc data: $locn{$loc}\n";
52 #}
53
54 # go back to the beginning and this time add prefixes (adding new location entries, if required)
55 seek(IN, 0, 0);
56
57 my $line;
58 while (<IN>) {
59         $line++;
60         chomp;
61         next if /^\s*\!/;                               # ignore comment lines
62         next if /^\s*$/;
63         
64         my @f  = split;                         # get each 'word'
65         next if @f == 0;                        # ignore blank lines
66   
67         # location record
68         my $locstr = join ' ', @f[1..13];
69         my $loc = $loc{$locstr};
70         $loc = addloc($locstr) if !$loc;
71   
72         my @prefixes = split /,/, $f[0];
73         foreach my $p (@prefixes) {
74                 my $ref;
75         
76                 if ($p =~ /#/) {
77                         my $i;
78                         for ($i = 0; $i < 9; ++$i) {
79                                 my $t = $p;
80                                 $t =~ s/#/$i/;
81                                 addpre($t, $loc);
82                         }
83                 } else {
84                         addpre($p, $loc);
85                 }       
86         }
87 }
88
89 close(IN);
90
91 #print Data::Dumper->Dump([\%pre, \%locn], [qw(pre locn)]);
92
93 # now open the rsgb.cty file and process that again the prefix file we have
94 open(IN, "$main::data/rsgb.cty") or die "Can't open $main::data/rsgb.cty ($!)";
95 $line = 0;
96 while (<IN>) {
97         $line++;
98         next if /^\s*#/;
99         next if /^\s*$/;
100         my $l = $_;
101         chomp;
102         my @f = split /:\s+|;/;
103         my $p = uc $f[4];
104         my $ref = $pre{$p};
105         if ($ref) {
106                 # split up the alias string
107                 my @alias = split /=/, $f[5];
108                 my $a;
109                 foreach $a (@alias) {
110                         next if $a eq $p;       # ignore if we have it already
111                         my $nref = $pre{$a};
112                         $pre{$a} = $ref if !$nref; # copy the original ref if new 
113                 }
114         } else {
115                 print "line $line: unknown prefix '$p' on $l in rsgb.cty\n";
116         }
117 }
118 close IN;
119
120 # now open the cty.dat file if it is there
121 my @f;
122 my @a;
123 $line = 0;
124 if (open(IN, "$main::data/cty.dat")) {
125         my $state = 0;
126         while (<IN>) {
127                 $line++;
128                 s/\r$//;
129                 next if /^\s*\#/;
130                 next if /^\s*$/;
131                 chomp;
132                 if ($state == 0) {
133                         s/:$//;
134                         @f = split /:\s+/;
135                         @a = ();
136                         $state = 1;
137                 } elsif ($state == 1) {
138                         s/^\s+//;
139                         if (/;$/) {
140                                 $state = 0;
141                                 s/[,;]$//;
142                                 push @a, split /\s*,/;
143                                 next if $f[7] =~ /^\*/;   # ignore callsigns starting '*'
144                                 ct($_, uc $f[7], @a) if @a;
145                         } else {
146                                 s/,$//;
147                                 push @a, split /\s*,/;
148                         }
149                 }
150         }
151 }
152 close IN;
153
154
155 open(OUT, ">$main::data/prefix_data.pl") or die "Can't open $main::data/prefix_data.pl ($!)";
156
157 print OUT "\%pre = (\n";
158 foreach my $k (sort keys %pre) {
159         my $ans = printpre($k);
160         print OUT "  '$k' => '$ans',\n";
161 }
162 print OUT ");\n\n";
163
164 print OUT "\n\%prefix_loc = (\n";
165 foreach my $l (sort {$a <=> $b} keys %locn) {
166         print OUT "   $l => bless( {";
167         my ($name, $dxcc, $itu, $cq, $utcoff, $latd, $latm, $lats, $latl, $longd, $longm, $longs, $longl) = split /\s+/, $locn{$l};
168   
169         $longd += ($longm/60);
170         $longd = 0-$longd if (uc $longl) eq 'W'; 
171         $latd += ($latm/60);
172         $latd = 0-$latd if (uc $latl) eq 'S';
173         print OUT " name => '$name',";
174         print OUT " dxcc => $dxcc,";
175         print OUT " itu => $itu,";
176         print OUT " cq => $cq,";
177         print OUT " utcoff => $utcoff,";
178         print OUT " lat => $latd,";
179         print OUT " long => $longd";
180         print OUT " }, 'Prefix'),\n";
181 }
182 print OUT ");\n\n";
183
184 close(OUT);
185
186 sub addpre
187 {
188         my ($p, $ent) = @_;
189         my $ref = $pre{$p};
190         $ref = $pre{$p} = [] if !$ref;
191         push @{$ref}, $ent;;
192 }
193
194 sub printpre
195 {
196         my $p = shift;
197         my $ref = $pre{$p};
198         my $out;
199         my $r;
200   
201         foreach $r (@{$ref}) {
202                 $out .= "$r,";
203         }
204         chop $out;
205         return $out;
206 }
207
208 sub ct
209 {
210         my $l = shift;
211         my $p = shift; 
212         my @a = @_;
213         my $ref = $pre{$p};
214         if ($ref) {
215                 my $a;
216                 foreach $a (@a) {
217                         # for now remove (nn) [nn]
218                         my ($itu) = $a =~ /(\(\d+\))/; $a =~ s/(\(\d+\))//g;
219                         my ($cq) = $a =~ /(\[\d+\])/; $a =~ s/(\[\d+\])//g;
220                         my ($lat, $long) = $a =~ m{(<[-+\d.]+/[-+\d.]+>)}; $a =~ s{(<[-+\d.]+/[-+\d.]+>)}{}g;
221
222                         unless ($a) {
223                                 print "line $line: blank prefix on $l in cty.dat\n";
224                                 next;
225                         }
226                         next if $a eq $p;       # ignore if we have it already
227                         my $nref = $pre{$a};
228                         $pre{$a} = $ref if !$nref; # copy the original ref if new 
229                 }
230         } else {
231                 print "line $line: unknown prefix '$p' on $l in cty.dat\n";
232         }
233 }
234
235 sub addloc
236 {
237         my $locstr = shift;
238         $locstr =~ s/\'/\\'/g;
239         my $loc = $loc{$locstr} = $nextloc++;
240         $locn{$loc} = $locstr;
241         return $loc;
242 }
243