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