]> scm.dxcluster.org Git - spider.git/blob - perl/QSL.pm
8849be0853cc5ce930e30701db57eab05ba7a247
[spider.git] / perl / QSL.pm
1 #!/usr/bin/perl -w
2 #
3 # Local 'autoqsl' module for DXSpider
4 #
5 # Copyright (c) 2003 Dirk Koopman G1TLH
6 #
7
8 package QSL;
9
10 use strict;
11 use DXVars;
12 use DXUtil;
13 use DB_File;
14 use DXDebug;
15
16 use vars qw($VERSION $BRANCH);
17 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
18 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /\d+\.\d+\.(\d+)\.(\d+)/  || (0,0));
19 $main::build += $VERSION;
20 $main::branch += $BRANCH;
21
22 use vars qw($qslfn $dbm);
23 $qslfn = 'qsl';
24 $dbm = undef;
25
26 sub init
27 {
28         my $mode = shift;
29         my $ufn = "$main::root/data/$qslfn.v1";
30
31         eval {
32                 require Storable;
33         };
34         
35         if ($@) {
36                 dbg("Storable appears to be missing");
37                 dbg("In order to use the QSL feature you must");
38                 dbg("load Storable from CPAN");
39                 return undef;
40         }
41         import Storable qw(nfreeze thaw);
42         my %u;
43         if ($mode) {
44                 $dbm = tie (%u, 'DB_File', $ufn, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)";
45         } else {
46                 $dbm = tie (%u, 'DB_File', $ufn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)";
47         }
48         return $dbm;
49 }
50
51 sub finish
52 {
53         undef $dbm;
54 }
55
56 sub new
57 {
58         my ($pkg, $call) = @_;
59         return bless [uc $call, []], $pkg;
60 }
61
62 # the format of each entry is [manager, times found, last time]
63 sub update
64 {
65         return unless $dbm;
66         my $self = shift;
67         my $line = shift;
68         my $t = shift;
69         my $by = shift;
70                 
71         my @tok = map {/^BUR/ || is_callsign($_) ? $_ : ()} split(/\b/, uc $line);
72         foreach my $man (@tok) {
73                 $man = 'BUREAU' if $man =~ /^BUR/;
74                 my ($r) = grep {$_->[0] eq $man} @{$self->[1]};
75                 if ($r) {
76                         $r->[1]++;
77                         if ($t > $r->[2]) {
78                                 $r->[2] = $t;
79                                 $r->[3] = $by;
80                         }
81                 } else {
82                         $r = [$man, 1, $t, $by];
83                         push @{$self->[1]}, $r;
84                 }
85         }
86         $self->put;
87 }
88
89 sub get
90 {
91         my $key = uc shift;
92         return undef unless $dbm;
93         my $value;
94         
95         my $r = $dbm->get($key, $value);
96         return undef if $r;
97         return thaw($value);
98 }
99
100 sub put
101 {
102         return unless $dbm;
103         my $self = shift;
104         my $key = $self->[0];
105         my $value = nfreeze($self);
106         $dbm->put($key, $value);
107 }
108
109 1;