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