]> gb7djk.dxcluster.net Git - spider.git/blob - perl/DXDupe.pm
add CTY-2614
[spider.git] / perl / DXDupe.pm
1 #
2 # class to handle all dupes in the system
3 #
4 # each dupe entry goes into a tied hash file 
5 #
6 # the only thing this class really does is provide a
7 # mechanism for storing and checking dups
8 #
9
10 package DXDupe;
11
12 use DXDebug;
13 use DXUtil;
14 use DXVars;
15
16 use vars qw{$lasttime $dbm %d $default $fn};
17
18 $default = 48*24*60*60;
19 $lasttime = 0;
20 localdata_mv("dupefile");
21 $fn = localdata("dupefile");
22
23 sub init
24 {
25         unlink $fn;
26         $dbm = tie (%d, 'DB_File', $fn);
27         confess "cannot open $fn $!" unless $dbm;
28 }
29
30 sub finish
31 {
32         undef $dbm;
33         untie %d;
34         undef %d;
35         unlink $fn;
36 }
37
38 sub check
39 {
40         my $s = shift;
41         return 1 if find($s);
42         add($s, shift);
43         return 0;
44 }
45
46 sub find
47 {
48         return $d{$_[0]};
49 }
50
51 sub add
52 {
53         my $s = shift;
54         my $t = shift || $main::systime + $default;
55         $d{$s} = $t;
56 }
57
58 sub del
59 {
60         my $s = shift;
61         delete $d{$s};
62 }
63
64 sub process
65 {
66         # once an hour
67         if ($main::systime - $lasttime >=  3600) {
68                 my @del;
69                 while (($k, $v) = each %d) {
70                         push @del, $k  if $main::systime >= $v;
71                 }
72                 delete $d{$_} for @del;
73                 $lasttime = $main::systime;
74         }
75 }
76
77 sub get
78 {
79         my $start = shift;
80         my @out;
81         while (($k, $v) = each %d) {
82                 push @out, $k, $v if !$start || $k =~ /^$start/; 
83         }
84         return @out;
85 }
86
87 sub listdups
88 {
89         my $let = shift;
90         my $dupage = shift;
91         my $regex = shift;
92
93         $regex =~ s/[\^\$\@\%]//g;
94         $regex = ".*$regex" if $regex;
95         $regex = "^$let" . $regex;
96         my @out;
97         for (sort { $d{$a} <=> $d{$b} } grep { m{$regex}i } keys %d) {
98                 my ($dum, $key) = unpack "a1a*", $_;
99                 push @out, "$key = " . cldatetime($d{$_} - $dupage) . " expires " . cldatetime($d{$_});
100         }
101         return @out;
102 }
103 1;