perl/create_localqsl.pl

   1 #!/usr/bin/perl
   2 #
   3 # Implement a 'GO' database list
   4 #
   5 # Copyright (c) 2003 Dirk Koopman G1TLH
   6 #
   7 # $Id$
   8 #
   9
  10 # search local then perl directories
  11 BEGIN {
  12         use vars qw($root);
  13
  14         # root of directory tree for this system
  15         $root = "/spider";
  16         $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
  17
  18         unshift @INC, "$root/perl";     # this IS the right way round!
  19         unshift @INC, "$root/local";
  20 }
  21
  22 use strict;
  23
  24 use IO::File;
  25 use DXVars;
  26 use DXUtil;
  27 use Spot;
  28 use DXDb;
  29
  30 my $end = 0;
  31 $SIG{TERM} = $SIG{INT} = sub { $end++ };
  32
  33 my $qslfn = "localqsl";
  34
  35 $main::systime = time;
  36
  37 DXDb::load();
  38 my $db = DXDb::getdesc($qslfn);
  39 unless ($db) {
  40         DXDb::new($qslfn);
  41         DXDb::load();
  42         $db = DXDb::getdesc($qslfn);
  43 }
  44
  45 die "cannot load $qslfn $!" unless $db;
  46
  47 my $base = "$root/data/spots";
  48
  49 opendir YEAR, $base or die "$base $!";
  50 foreach my $year (sort readdir YEAR) {
  51         next if $year =~ /^\./;
  52         my $baseyear = "$base/$year";
  53         opendir DAY,  $baseyear or die "$baseyear $!";
  54         foreach my $day (sort readdir DAY) {
  55                 next unless $day =~ /dat$/;
  56                 my $fn = "$baseyear/$day";
  57                 my $f = new IO::File $fn  or die "$fn ($!)";
  58                 print "doing: $fn\n";
  59                 while (<$f>) {
  60                         if (/(QSL|VIA)/i) {
  61                                 my ($freq, $call, $t, $comment, $by, @rest) = split /\^/;
  62                                 my $value = $db->getkey($call) || "";
  63                                 my $newvalue = update($value, $call, $t, $comment, $by);
  64                                 if ($newvalue ne $value) {
  65                                         $db->putkey($call, $newvalue);
  66                                 }
  67                         }
  68                 }
  69                 $f->close;
  70         }
  71 }
  72
  73 DXDb::closeall();
  74 exit(0);
  75
  76 sub update
  77 {
  78         my ($line, $call, $t, $comment, $by) = @_;
  79         my @lines = split /\n/, $line;
  80         my @in;
  81
  82         # decode the lines
  83         foreach my $l (@lines) {
  84                 my ($date, $time, $oby, $ocom) = $l =~ /^(\s?\S+)\s+(\s?\S+)\s+by\s+(\S+):\s+(.*)$/;
  85                 if ($date) {
  86                         my $ot = cltounix($date, $time);
  87                         push @in, [$ot, $oby, $ocom];
  88                 } else {
  89                         print "Cannot decode $call: $l\n";
  90                         $DB::single = 1;
  91                 }
  92
  93         }
  94
  95         # is this newer than the earliest one?
  96         if (@in && $in[0]->[0] < $t) {
  97                 @in = grep {$_->[1] ne $by} @in;
  98         }
  99         unshift @in, [$t, $by, $comment];
 100         pop @in, if @in > 5;
 101         return join "\n", (map {(cldatetime($_->[0]) . " by $_->[1]: $_->[2]")} @in);
 102 }
 103