add localqsl a la golist thing

diff --git a/perl/DXDb.pm b/perl/DXDb.pm
index 6a57dc7cc8db3003ce7338b3288aff94fb2b0656..f54d6f14ff02b882fbefdd26cf21bbcab0fa1f4b 100644 (file)
--- a/perl/DXDb.pm
+++ b/perl/DXDb.pm
@@ -194,6 +194,7 @@ sub new
        $avail{$self->{name}} = $self;
        mkdir $dbbase, 02775 unless -e $dbbase;
        save();
+       return $self;
 }
 
 # delete a database

diff --git a/perl/Spot.pm b/perl/Spot.pm
index 8674e111a111e74b6f10459e787edde67138dba6..f59ef4f4965bca34c5b747d30c0c9b03390bfc5e 100644 (file)
--- a/perl/Spot.pm
+++ b/perl/Spot.pm
@@ -101,8 +101,9 @@ sub init
        mkdir "$dirprefix", 0777 if !-e "$dirprefix";
        $fp = DXLog::new($dirprefix, "dat", 'd');
        $statp = DXLog::new($dirprefix, "dys", 'd');
-       system("rm -f $main::data/$dirprefix/200?/*.bys");
-       system("rm -f $main::data/$dirprefix/200?/*.cys");
+       my $rm = $main::is_win ? 'del' : 'rm -f';
+       system("$rm $main::data/$dirprefix/*/*.bys");
+       system("$rm $main::data/$dirprefix/*/*.cys");
 }
 
 sub prefix

diff --git a/perl/create_localqsl.pl b/perl/create_localqsl.pl
new file mode 100755 (executable)
index 0000000..2d3fc57
--- /dev/null
+++ b/perl/create_localqsl.pl
@@ -0,0 +1,98 @@
+#!/usr/bin/perl
+#
+# Implement a 'GO' database list
+#
+# Copyright (c) 2003 Dirk Koopman G1TLH
+#
+# $Id$
+#
+
+# search local then perl directories
+BEGIN {
+       use vars qw($root);
+       
+       # root of directory tree for this system
+       $root = "/spider"; 
+       $root = $ENV{'DXSPIDER_ROOT'} if $ENV{'DXSPIDER_ROOT'};
+       
+       unshift @INC, "$root/perl";     # this IS the right way round!
+       unshift @INC, "$root/local";
+}
+
+use strict;
+
+use IO::File;
+use DXVars;
+use DXUtil;
+use Spot;
+use DXDb;
+
+my $qslfn = "localqsl";
+
+$main::systime = time;
+
+DXDb::load();
+my $db = DXDb::getdesc($qslfn);
+unless ($db) {
+       DXDb::new($qslfn);
+       DXDb::load();
+       $db = DXDb::getdesc($qslfn);
+}
+
+die "cannot load $qslfn $!" unless $db;
+
+my $base = "$root/data/spots";
+
+opendir YEAR, $base or die "$base $!";
+foreach my $year (sort readdir YEAR) {
+       next if $year =~ /^\./;
+       my $baseyear = "$base/$year";
+       opendir DAY,  $baseyear or die "$baseyear $!";
+       foreach my $day (sort readdir DAY) {
+               next if $day =~ /^\./;
+               my $fn = "$baseyear/$day";
+               my $f = new IO::File $fn  or die "$fn ($!)"; 
+               while (<$f>) {
+                       if (/(QSL|VIA)/i) {
+                               my ($freq, $call, $t, $comment, $by, @rest) = split /\^/;
+                               my $value = $db->getkey($call) || "";
+                               my $newvalue = update($value, $call, $t, $comment, $by);
+                               if ($newvalue ne $value) {
+                                       $db->putkey($call, $newvalue);
+                               }
+                       }
+               }
+       }
+}
+
+DXDb::closeall();
+exit(0);
+
+sub update
+{
+       my ($line, $call, $t, $comment, $by) = @_;
+       my @lines = split /\n/, $line;
+       my @in;
+       
+       # decode the lines
+       foreach my $l (@lines) {
+               my ($date, $time, $oby, $ocom) = $l =~ /^(\s?\S+)\s+(\s?\S+)\s+by\s+(\S+):\s+(.*)$/;
+               if ($date) {
+                       my $ot = cltounix($date, $time);
+                       push @in, [$ot, $oby, $ocom];
+               } else {
+                       print "Cannot decode $call: $l\n";
+                       $DB::single = 1;
+               }
+               
+       }
+       
+       # is this newer than the earliest one?
+       if (@in && $in[0]->[0] < $t) {
+               @in = grep {$_->[1] ne $by} @in;
+       }
+       unshift @in, [$t, $by, $comment];
+       pop @in, if @in > 5;
+       return join "\n", (map {(cldatetime($_->[0]) . " by $_->[1]: $_->[2]")} @in);
+}
+