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