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 $qslfn = "localqsl";
  31
  32 $main::systime = time;
  33
  34 DXDb::load();
  35 my $db = DXDb::getdesc($qslfn);
  36 unless ($db) {
  37         DXDb::new($qslfn);
  38         DXDb::load();
  39         $db = DXDb::getdesc($qslfn);
  40 }
  41
  42 die "cannot load $qslfn $!" unless $db;
  43
  44 my $base = "$root/data/spots";
  45
  46 opendir YEAR, $base or die "$base $!";
  47 foreach my $year (sort readdir YEAR) {
  48         next if $year =~ /^\./;
  49         my $baseyear = "$base/$year";
  50         opendir DAY,  $baseyear or die "$baseyear $!";
  51         foreach my $day (sort readdir DAY) {
  52                 next if $day =~ /^\./;
  53                 my $fn = "$baseyear/$day";
  54                 my $f = new IO::File $fn  or die "$fn ($!)";
  55                 while (<$f>) {
  56                         if (/(QSL|VIA)/i) {
  57                                 my ($freq, $call, $t, $comment, $by, @rest) = split /\^/;
  58                                 my $value = $db->getkey($call) || "";
  59                                 my $newvalue = update($value, $call, $t, $comment, $by);
  60                                 if ($newvalue ne $value) {
  61                                         $db->putkey($call, $newvalue);
  62                                 }
  63                         }
  64                 }
  65         }
  66 }
  67
  68 DXDb::closeall();
  69 exit(0);
  70
  71 sub update
  72 {
  73         my ($line, $call, $t, $comment, $by) = @_;
  74         my @lines = split /\n/, $line;
  75         my @in;
  76
  77         # decode the lines
  78         foreach my $l (@lines) {
  79                 my ($date, $time, $oby, $ocom) = $l =~ /^(\s?\S+)\s+(\s?\S+)\s+by\s+(\S+):\s+(.*)$/;
  80                 if ($date) {
  81                         my $ot = cltounix($date, $time);
  82                         push @in, [$ot, $oby, $ocom];
  83                 } else {
  84                         print "Cannot decode $call: $l\n";
  85                         $DB::single = 1;
  86                 }
  87
  88         }
  89
  90         # is this newer than the earliest one?
  91         if (@in && $in[0]->[0] < $t) {
  92                 @in = grep {$_->[1] ne $by} @in;
  93         }
  94         unshift @in, [$t, $by, $comment];
  95         pop @in, if @in > 5;
  96         return join "\n", (map {(cldatetime($_->[0]) . " by $_->[1]: $_->[2]")} @in);
  97 }
  98