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 }