From 8032b90ab5f686159bc725b43d28862c42ad55d5 Mon Sep 17 00:00:00 2001 From: minima Date: Fri, 7 Mar 2003 18:40:42 +0000 Subject: [PATCH] add localqsl a la golist thing --- perl/DXDb.pm | 1 + perl/Spot.pm | 5 ++- perl/create_localqsl.pl | 98 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 102 insertions(+), 2 deletions(-) create mode 100755 perl/create_localqsl.pl diff --git a/perl/DXDb.pm b/perl/DXDb.pm index 6a57dc7c..f54d6f14 100644 --- 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 8674e111..f59ef4f4 100644 --- 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 index 00000000..2d3fc57e --- /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); +} + -- 2.43.0