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 }