]> dxcluster.net Git - spider.git/blob - perl/AnnTalk.pm
fix BadWord to break on word boundaries
[spider.git] / perl / AnnTalk.pm
1 #
2 # Announce and Talk Handling routines
3 #
4 # Copyright (c) 2000 Dirk Koopman
5 #
6 # $Id$
7 #
8
9 package AnnTalk;
10
11 use strict;
12
13 use DXUtil;
14 use DXDebug;
15 use DXDupe;
16 use DXVars;
17
18 use vars qw(%dup $duplth $dupage $filterdef);
19
20 $duplth = 60;                                   # the length of text to use in the deduping
21 $dupage = 5*24*3600;                    # the length of time to hold spot dups
22 $filterdef = bless ([
23                           # tag, sort, field, priv, special parser 
24                           ['by', 'c', 0],
25                           ['dest', 'c', 1],
26                           ['info', 't', 2],
27                           ['group', 't', 3],
28                           ['origin', 'c', 4],
29                           ['wx', 't', 5],
30                           ['channel', 'c', 6],
31                           ['by_dxcc', 'nc', 7],
32                           ['by_itu', 'ni', 8],
33                           ['by_zone', 'nz', 9],
34                           ['origin_dxcc', 'nc', 10],
35                           ['origin_itu', 'ni', 11],
36                           ['origin_zone', 'nz', 12],
37                           ['by_state', 'nz', 13],
38                           ['origin_state', 'nz', 14],
39                          ], 'Filter::Cmd');
40
41 use vars qw($VERSION $BRANCH);
42 $VERSION = sprintf( "%d.%03d", q$Revision$ =~ /(\d+)\.(\d+)/ );
43 $BRANCH = sprintf( "%d.%03d", q$Revision$ =~ /^\d+\.\d+(?:\.(\d+)\.(\d+))?$/  || (0,0));
44 $main::build += $VERSION;
45 $main::branch += $BRANCH;
46
47 # enter the spot for dup checking and return true if it is already a dup
48 sub dup
49 {
50         my ($call, $to, $text, $t) = @_; 
51
52         $t ||= $main::systime + $dupage;
53         chomp $text;
54         unpad($text);
55         $text =~ s/\%([0-9A-F][0-9A-F])/chr(hex($1))/eg;
56         $text = pack("C*", map {$_ & 127} unpack("C*", $text));
57         $text =~ s/[^\#a-zA-Z0-9]//g;
58         $text = substr($text, 0, $duplth) if length $text > $duplth; 
59         my $dupkey = "A$to|\L$text";
60         return DXDupe::check($dupkey, $t);
61 }
62
63 sub listdups
64 {
65         return DXDupe::listdups('A', $dupage, @_);
66 }
67
68 # is this text field a likely announce to talk substitution?
69 # this may involve all sorts of language dependant heuristics, but 
70 # then again, it might not
71 sub is_talk_candidate
72 {
73         my ($from, $text) = @_;
74         my $call;
75         ($call) = $text =~ /^\s*(?:[Xx]|[Tt][Oo]?:?)\s+([\w-]+)/;
76         ($call) = $text =~ /^\s*>\s*([\w-]+)\b/ unless $call;
77         ($call) = $text =~ /^\s*([\w-]+):?\b/ unless $call;
78         if ($call) {
79                 $call = uc $call;
80                 return is_callsign($call);
81         }
82     return undef;
83 }
84 1; 
85