]> scm.dxcluster.org Git - spider.git/blob - perl/DXDupe.pm
allow PC92(A/D) to be slugged and aggregated
[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 $fn = "$main::data/dupefile";
21
22 sub init
23 {
24         unlink $fn;
25         $dbm = tie (%d, 'DB_File', $fn);
26         confess "cannot open $fn $!" unless $dbm;
27 }
28
29 sub finish
30 {
31         undef $dbm;
32         untie %d;
33         undef %d;
34         unlink $fn;
35 }
36
37 sub check
38 {
39         my $s = shift;
40         return 1 if find($s);
41         add($s, shift);
42         return 0;
43 }
44
45 sub find
46 {
47         return $d{$_[0]};
48 }
49
50 sub add
51 {
52         my $s = shift;
53         my $t = shift || $main::systime + $default;
54         $d{$s} = $t;
55 }
56
57 sub del
58 {
59         my $s = shift;
60         delete $d{$s};
61 }
62
63 sub process
64 {
65         # once an hour
66         if ($main::systime - $lasttime >=  3600) {
67                 my @del;
68                 while (($k, $v) = each %d) {
69                         push @del, $k  if $main::systime >= $v;
70                 }
71                 delete $d{$_} for @del;
72                 $lasttime = $main::systime;
73         }
74 }
75
76 sub get
77 {
78         my $start = shift;
79         my @out;
80         while (($k, $v) = each %d) {
81                 push @out, $k, $v if !$start || $k =~ /^$start/; 
82         }
83         return @out;
84 }
85
86 sub listdups
87 {
88         my $let = shift;
89         my $dupage = shift;
90         my $regex = shift;
91
92         $regex =~ s/[\^\$\@\%]//g;
93         $regex = ".*$regex" if $regex;
94         $regex = "^$let" . $regex;
95         my @out;
96         for (sort { $d{$a} <=> $d{$b} } grep { m{$regex}i } keys %d) {
97                 my ($dum, $key) = unpack "a1a*", $_;
98                 push @out, "$key = " . cldatetime($d{$_} - $dupage) . " expires " . cldatetime($d{$_});
99         }
100         return @out;
101 }
102 1;