]> scm.dxcluster.org Git - spider.git/blob - perl/QSL.pm
fix pc20 disconnect
[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 use Prefix;
16
17 use vars qw($qslfn $dbm);
18 $qslfn = 'qsl';
19 $dbm = undef;
20
21 sub init
22 {
23         my $mode = shift;
24         my $ufn = "$main::root/data/$qslfn.v1";
25
26         Prefix::load() unless Prefix::loaded();
27         
28         eval {
29                 require Storable;
30         };
31         
32         if ($@) {
33                 dbg("Storable appears to be missing");
34                 dbg("In order to use the QSL feature you must");
35                 dbg("load Storable from CPAN");
36                 return undef;
37         }
38         import Storable qw(nfreeze freeze thaw);
39         my %u;
40         if ($mode) {
41                 $dbm = tie (%u, 'DB_File', $ufn, O_CREAT|O_RDWR, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)";
42         } else {
43                 $dbm = tie (%u, 'DB_File', $ufn, O_RDONLY, 0666, $DB_BTREE) or confess "can't open qsl file: $qslfn ($!)";
44         }
45         return $dbm;
46 }
47
48 sub finish
49 {
50         undef $dbm;
51 }
52
53 sub new
54 {
55         my ($pkg, $call) = @_;
56         return bless [uc $call, []], $pkg;
57 }
58
59 # the format of each entry is [manager, times found, last time]
60 sub update
61 {
62         return unless $dbm;
63         my $self = shift;
64         my $line = shift;
65         my $t = shift;
66         my $by = shift;
67         my $changed;
68                         
69         foreach my $man (split /\b/, uc $line) {
70                 my $tok;
71                 
72                 if (is_callsign($man)) {
73                         my @pre = Prefix::extract($man);
74                         $tok = $man if @pre && $pre[0] ne 'Q';
75                 } elsif ($man =~ /^BUR/) {
76                         $tok = 'BUREAU';
77                 } elsif ($man eq 'HC' || $man =~ /^HOM/ || $man =~ /^DIR/) {
78                         $tok = 'HOME CALL';
79                 } elsif ($man =~ /^QRZ/) {
80                         $tok = 'QRZ.com';
81                 }
82                 if ($tok) {
83                         my ($r) = grep {$_->[0] eq $tok} @{$self->[1]};
84                         if ($r) {
85                                 $r->[1]++;
86                                 if ($t > $r->[2]) {
87                                         $r->[2] = $t;
88                                         $r->[3] = $by;
89                                 }
90                                 $changed++;
91                         } else {
92                                 $r = [$tok, 1, $t, $by];
93                                 unshift @{$self->[1]}, $r;
94                                 $changed++;
95                         }
96                 }
97         }
98         $self->put if $changed;
99 }
100
101 sub get
102 {
103         return undef unless $dbm;
104         my $key = uc shift;
105         my $value;
106         
107         my $r = $dbm->get($key, $value);
108         return undef if $r;
109         return thaw($value);
110 }
111
112 sub put
113 {
114         return unless $dbm;
115         my $self = shift;
116         my $key = $self->[0];
117         my $value = nfreeze($self);
118         $dbm->put($key, $value);
119 }
120
121 1;