]> scm.dxcluster.org Git - spider.git/blob - perl/create_prefix.pl
removed ~ from the end of a PC18
[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
24 %loc = ();        # the location unique hash
25 $nextloc = 1;     # the next location number
26 %locn = ();       # the inverse of the above
27 %pre = ();        # the prefix hash
28 %pren = ();       # the inverse
29
30 # open the input file
31 $ifn = $ARGV[0] if $ARGV[0];
32 $ifn = "$data/wpxloc.raw" if !$fn;
33 open (IN, $ifn) or die "can't open $ifn ($!)";
34
35 # first pass, find all the 'master' location records
36 while (<IN>) {
37   next if /^\!/;    # ignore comment lines
38   chomp;
39   @f  = split;       # get each 'word'
40   next if @f == 0;   # ignore blank lines
41
42   if ($f[14] eq '@' || $f[15] eq '@') {
43     $locstr = join ' ', @f[1..13];
44     $loc = $loc{$locstr};
45     $loc = addloc($locstr) if !$loc;
46   }
47 }
48
49 #foreach $loc (sort {$a <=> $b;} keys %locn) {
50 #  print "loc: $loc data: $locn{$loc}\n";
51 #}
52
53 # go back to the beginning and this time add prefixes (adding new location entries, if required)
54 seek(IN, 0, 0);
55
56 while (<IN>) {
57   $line++;
58   next if /^\!/;    # ignore comment lines
59   chomp;
60   @f  = split;       # get each 'word'
61   next if @f == 0;   # ignore blank lines
62   
63   # location record
64   $locstr = join ' ', @f[1..13];
65   $loc = $loc{$locstr};
66   $loc = addloc($locstr) if !$loc;
67   
68   @prefixes = split /,/, $f[0];
69   foreach $p (@prefixes) {
70     my $ref;
71         
72         if ($p =~ /#/) {
73           my $i;
74           for ($i = 0; $i < 9; ++$i) {
75             my $t = $p;
76                 $t =~ s/#/$i/;
77                 addpre($t, $loc);
78           }
79         } else {
80           addpre($p, $loc);
81     }   
82   }
83 }
84
85 close(IN);
86
87 #print Data::Dumper->Dump([\%pre, \%locn], [qw(pre locn)]);
88
89 # now open the rsgb.cty file and process that again the prefix file we have
90 open(IN, "$data/rsgb.cty") or die "Can't open $data/rsgb.cty ($!)";
91 while (<IN>) {
92   chomp;
93   @f = split /:\s+|;/;
94   my $p = uc $f[4];
95   my $ref = $pre{$p};
96   if ($ref) {
97     # split up the alias string
98         my @alias = split /=/, $f[5];
99         my $a;
100         foreach $a (@alias) {
101           next if $a eq $p;  # ignore if we have it already
102           my $nref = $pre{$a};
103           $pre{$a} = $ref if !$nref;       # copy the original ref if new 
104         }
105   } else {
106     print "unknown prefix $p\n";
107   }
108 }
109
110 open(OUT, ">$data/prefix_data.pl") or die "Can't open $data/prefix_data.pl ($!)";
111
112 print OUT "\%pre = (\n";
113 foreach $k (sort keys %pre) {
114   my $ans = printpre($k);
115   print OUT "  '$k' => '$ans',\n";
116 }
117 print OUT ");\n\n";
118
119 print OUT "\n\%prefix_loc = (\n";
120 foreach $l (sort {$a <=> $b} keys %locn) {
121   print OUT "   $l => bless( {";
122   my ($name, $dxcc, $itu, $cq, $utcoff, $latd, $latm, $lats, $latl, $longd, $longm, $longs, $longl) = split /\s+/, $locn{$l};
123   
124   $longd += ($longm/60);
125   $longd = 0-$longd if (uc $longl) eq 'W'; 
126   $latd += ($latm/60);
127   $latd = 0-$latd if (uc $latl) eq 'S';
128   print OUT " name => '$name',";
129   print OUT " dxcc => $dxcc,";
130   print OUT " itu => $itu,";
131   print OUT " cq => $cq,";
132   print OUT " utcoff => $utcoff,";
133   print OUT " lat => $latd,";
134   print OUT " long => $longd";
135   print OUT " }, 'Prefix'),\n";
136 }
137 print OUT ");\n\n";
138
139 close(OUT);
140
141 sub addpre
142 {
143   my ($p, $ent) = @_;
144   my $ref = $pre{$p};
145   $ref = $pre{$p} = [] if !$ref;
146   push @{$ref}, $ent;;
147 }
148
149 sub printpre
150 {
151   my $p = shift;
152   my $ref = $pre{$p};
153   my $out;
154   my $r;
155   
156   foreach $r (@{$ref}) {
157     $out .= "$r,";
158   }
159   chop $out;
160   return $out;
161 }
162
163 sub addloc
164 {
165   my $locstr = shift;
166   $locstr =~ s/\'/\\'/g;
167   my $loc = $loc{$locstr} = $nextloc++;
168   $locn{$loc} = $locstr;
169   return $loc;
170 }