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 use vars qw($end $lastyear $lastday);
  31
  32 $end = 0;
  33 $SIG{TERM} = $SIG{INT} = sub { $end++ };
  34
  35 my $qslfn = "localqsl";
  36 $lastyear = 0;
  37 $lastday = 0;
  38
  39 $main::systime = time;
  40
  41 DXDb::load();
  42 my $db = DXDb::getdesc($qslfn);
  43 unless ($db) {
  44         DXDb::new($qslfn);
  45         DXDb::load();
  46         $db = DXDb::getdesc($qslfn);
  47 }
  48 die "cannot load $qslfn $!" unless $db;
  49
  50 # find start point (if any)
  51 my $statefn = "$root/data/$qslfn.state";
  52 my $s = readfilestr($statefn);
  53 eval $s if $s;
  54
  55 my $base = "$root/data/spots";
  56
  57 opendir YEAR, $base or die "$base $!";
  58 foreach my $year (sort readdir YEAR) {
  59         next if $year =~ /^\./;
  60         next unless $year ge $lastyear;
  61
  62         my $baseyear = "$base/$year";
  63         opendir DAY,  $baseyear or die "$baseyear $!";
  64         foreach my $day (sort readdir DAY) {
  65                 next unless $day =~ /(\d+)\.dat$/;
  66                 my $dayno = $1 + 0;
  67                 next unless $dayno >= $lastday;
  68
  69                 my $fn = "$baseyear/$day";
  70                 my $f = new IO::File $fn  or die "$fn ($!)";
  71                 print "doing: $fn\n";
  72                 while (<$f>) {
  73                         if (/(QSL|VIA)/i) {
  74                                 my ($freq, $call, $t, $comment, $by, @rest) = split /\^/;
  75                                 my $value = $db->getkey($call) || "";
  76                                 my $newvalue = update($value, $call, $t, $comment, $by);
  77                                 if ($newvalue ne $value) {
  78                                         $db->putkey($call, $newvalue);
  79                                 }
  80                         }
  81                 }
  82                 $f->close;
  83                 $f = new IO::File ">$statefn" or die "cannot open $statefn $!";
  84                 print $f "\$lastyear = $year; \$lastday = $dayno;\n";
  85                 $f->close;
  86         }
  87 }
  88
  89 DXDb::closeall();
  90 exit(0);
  91
  92 sub update
  93 {
  94         my ($line, $call, $t, $comment, $by) = @_;
  95         my @lines = split /\n/, $line;
  96         my @in;
  97
  98         # decode the lines
  99         foreach my $l (@lines) {
 100                 my ($date, $time, $oby, $ocom) = $l =~ /^(\s?\S+)\s+(\s?\S+)\s+by\s+(\S+):\s+(.*)$/;
 101                 if ($date) {
 102                         my $ot = cltounix($date, $time);
 103                         push @in, [$ot, $oby, $ocom];
 104                 } else {
 105                         print "Cannot decode $call: $l\n";
 106                         $DB::single = 1;
 107                 }
 108
 109         }
 110
 111         # is this newer than the earliest one?
 112         if (@in && $in[0]->[0] < $t) {
 113                 @in = grep {$_->[1] ne $by} @in;
 114         }
 115         $comment =~ s/://g;
 116         unshift @in, [$t, $by, $comment] if grep is_callsign($_), split(/\s+/, $comment);
 117         pop @in, if @in > 10;
 118         return join "\n", (map {(cldatetime($_->[0]) . " by $_->[1]: $_->[2]")} @in);
 119 }
 120