]> dxcluster.org Git - spider.git/blob - perl/create_prefix.pl
add DXSql module and condiational processing
[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 cty.dat file if it is there
94 my @f;
95 my @a;
96 $line = 0;
97 if (open(IN, "$main::data/cty.dat")) {
98         my $state = 0;
99         while (<IN>) {
100                 $line++;
101                 s/\r$//;
102                 next if /^\s*\#/;
103                 next if /^\s*$/;
104                 chomp;
105                 if ($state == 0) {
106                         s/:$//;
107                         @f = split /:\s+/;
108                         @a = ();
109                         $state = 1;
110                 } elsif ($state == 1) {
111                         s/^\s+//;
112                         if (/;$/) {
113                                 $state = 0;
114                                 s/[,;]$//;
115                                 push @a, split /\s*,/;
116                                 $f[7] =~ s/^\*\s*//;   # remove any preceeding '*' before a callsign
117                                 ct($_, uc $f[7], @a) if @a;
118                         } else {
119                                 s/,$//;
120                                 push @a, split /\s*,/;
121                         }
122                 }
123         }
124 }
125 close IN;
126
127
128 open(OUT, ">$main::data/prefix_data.pl") or die "Can't open $main::data/prefix_data.pl ($!)";
129
130 print OUT "\%pre = (\n";
131 foreach my $k (sort keys %pre) {
132         my $ans = printpre($k);
133         print OUT "  '$k' => '$ans',\n";
134 }
135 print OUT ");\n\n";
136
137 print OUT "\n\%prefix_loc = (\n";
138 foreach my $l (sort {$a <=> $b} keys %locn) {
139         print OUT "   $l => bless( {";
140         my ($name, $dxcc, $itu, $cq, $utcoff, $latd, $latm, $lats, $latl, $longd, $longm, $longs, $longl) = split /\s+/, $locn{$l};
141   
142         $longd += ($longm/60);
143         $longd = 0-$longd if (uc $longl) eq 'W'; 
144         $latd += ($latm/60);
145         $latd = 0-$latd if (uc $latl) eq 'S';
146         print OUT " name => '$name',";
147         print OUT " dxcc => $dxcc,";
148         print OUT " itu => $itu,";
149         print OUT " cq => $cq,";
150         print OUT " utcoff => $utcoff,";
151         print OUT " lat => $latd,";
152         print OUT " long => $longd";
153         print OUT " }, 'Prefix'),\n";
154 }
155 print OUT ");\n\n";
156
157 close(OUT);
158
159 sub addpre
160 {
161         my ($p, $ent) = @_;
162         my $ref = $pre{$p};
163         $ref = $pre{$p} = [] if !$ref;
164         push @{$ref}, $ent;;
165 }
166
167 sub printpre
168 {
169         my $p = shift;
170         my $ref = $pre{$p};
171         my $out;
172         my $r;
173   
174         foreach $r (@{$ref}) {
175                 $out .= "$r,";
176         }
177         chop $out;
178         return $out;
179 }
180
181 sub ct
182 {
183         my $l = shift;
184         my $p = shift; 
185         my @a = @_;
186         my $ref = $pre{$p};
187         if ($ref) {
188                 my $a;
189                 foreach $a (@a) {
190                         # for now remove (nn) [nn]
191                         my ($itu) = $a =~ /(\(\d+\))/; $a =~ s/(\(\d+\))//g;
192                         my ($cq) = $a =~ /(\[\d+\])/; $a =~ s/(\[\d+\])//g;
193                         my ($lat, $long) = $a =~ m{(<[-+\d.]+/[-+\d.]+>)}; $a =~ s{(<[-+\d.]+/[-+\d.]+>)}{}g;
194                         my ($cont) = $a =~ /(\{[A-Z]{2}\})/; $a =~ s/(\{[A-Z]{2}\})//g;
195
196                         unless ($a) {
197                                 print "line $line: blank prefix on $l in cty.dat\n";
198                                 next;
199                         }
200                         next if $a eq $p;       # ignore if we have it already
201                         my $nref = $pre{$a};
202                         $pre{$a} = $ref if !$nref; # copy the original ref if new 
203                 }
204         } else {
205                 print "line $line: unknown prefix '$p' on $l in cty.dat\n";
206         }
207 }
208
209 sub addloc
210 {
211         my $locstr = shift;
212         $locstr =~ s/\'/\\'/g;
213         my $loc = $loc{$locstr} = $nextloc++;
214         $locn{$loc} = $locstr;
215         return $loc;
216 }
217