]> scm.dxcluster.org Git - spider.git/blob - perl/create_prefix.pl
*** empty log message ***
[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
119 open(OUT, ">$main::data/prefix_data.pl") or die "Can't open $main::data/prefix_data.pl ($!)";
120
121 print OUT "\%pre = (\n";
122 foreach my $k (sort keys %pre) {
123         my $ans = printpre($k);
124         print OUT "  '$k' => '$ans',\n";
125 }
126 print OUT ");\n\n";
127
128 print OUT "\n\%prefix_loc = (\n";
129 foreach my $l (sort {$a <=> $b} keys %locn) {
130         print OUT "   $l => bless( {";
131         my ($name, $dxcc, $itu, $cq, $utcoff, $latd, $latm, $lats, $latl, $longd, $longm, $longs, $longl) = split /\s+/, $locn{$l};
132   
133         $longd += ($longm/60);
134         $longd = 0-$longd if (uc $longl) eq 'W'; 
135         $latd += ($latm/60);
136         $latd = 0-$latd if (uc $latl) eq 'S';
137         print OUT " name => '$name',";
138         print OUT " dxcc => $dxcc,";
139         print OUT " itu => $itu,";
140         print OUT " cq => $cq,";
141         print OUT " utcoff => $utcoff,";
142         print OUT " lat => $latd,";
143         print OUT " long => $longd";
144         print OUT " }, 'Prefix'),\n";
145 }
146 print OUT ");\n\n";
147
148 close(OUT);
149
150 sub addpre
151 {
152         my ($p, $ent) = @_;
153         my $ref = $pre{$p};
154         $ref = $pre{$p} = [] if !$ref;
155         push @{$ref}, $ent;;
156 }
157
158 sub printpre
159 {
160         my $p = shift;
161         my $ref = $pre{$p};
162         my $out;
163         my $r;
164   
165         foreach $r (@{$ref}) {
166                 $out .= "$r,";
167         }
168         chop $out;
169         return $out;
170 }
171
172 sub addloc
173 {
174         my $locstr = shift;
175         $locstr =~ s/\'/\\'/g;
176         my $loc = $loc{$locstr} = $nextloc++;
177         $locn{$loc} = $locstr;
178         return $loc;
179 }