From 8032b90ab5f686159bc725b43d28862c42ad55d5 Mon Sep 17 00:00:00 2001
From: minima <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