1 #! @PERL@ |
|
2 # © 2006,2007 Heiko Schlittermann <hs@schlittermann.de> |
|
3 # Quick and dirty. Absolutly no warranty. Not even for spelling ;-) |
|
4 # $Id$ |
|
5 # $URL$ |
|
6 |
|
7 use constant USAGE => <<'#'; |
|
8 |
|
9 Usage: !ME! --insert item [delay [db]] # insert an item |
|
10 !ME! --remove item # remove an item |
|
11 !ME! --list [db] # list all items |
|
12 !ME! --stat [db* ...] # print short statistic |
|
13 !ME! --clean [days [db* ...]] # remove items not used since <days> days |
|
14 !ME! --purge [days [db* ...]] # remove items older than <days> days |
|
15 !ME! --dbs [db* ...] # list data base(s) |
|
16 |
|
17 db -- single name of database |
|
18 db* -- glob pattern of database |
|
19 |
|
20 If the data base name doesn't doesn't start with "./" or "/" |
|
21 it is considered to be realtiv to exim_spool_dir/grey/. |
|
22 |
|
23 # |
|
24 |
|
25 use strict; |
|
26 use warnings; |
|
27 use Getopt::Long; |
|
28 use File::Basename; |
|
29 use File::Temp qw/tmpfile/; |
|
30 use constant ME => basename $0; |
|
31 use FindBin qw/$Bin/; |
|
32 use POSIX qw/strftime mktime/; |
|
33 |
|
34 do './exim-exigrey.pl' |
|
35 or do '@LIBDIR@/exigrey.pl' |
|
36 or die $!; |
|
37 |
|
38 my $VERSION = '$Id$'; |
|
39 |
|
40 my $opt_list; |
|
41 my $opt_stats; |
|
42 my $opt_insert; |
|
43 my $opt_help; |
|
44 my $opt_clean; |
|
45 my $opt_purge; |
|
46 my $opt_dbs; |
|
47 my $opt_remove; |
|
48 |
|
49 sub getDBs(@); |
|
50 sub iterate(\%$); |
|
51 |
|
52 MAIN: { |
|
53 |
|
54 GetOptions( |
|
55 "list!" => \$opt_list, |
|
56 "insert!" => \$opt_insert, |
|
57 "remove!" => \$opt_remove, |
|
58 "stats!" => \$opt_stats, |
|
59 "clean!" => \$opt_clean, |
|
60 "purge!" => \$opt_purge, |
|
61 "dbs!" => \$opt_dbs, |
|
62 "help!" => \$opt_help, |
|
63 ) or die ME . ": Bad usage, try " . ME . " --help.\n"; |
|
64 |
|
65 if ($opt_help) { |
|
66 ($_ = USAGE) =~ s/!(.*?)!/eval $1/eg; |
|
67 print; |
|
68 exit 0; |
|
69 } |
|
70 |
|
71 if ($opt_list) { |
|
72 foreach (@ARGV = getDBs(@ARGV)) { |
|
73 my %h; |
|
74 my $db = connectDB(\%h, $_); |
|
75 print "# $db\n"; |
|
76 iterate( |
|
77 %h, |
|
78 sub { |
|
79 my ($item, $v0, $v1, $c, $flag) = @_; |
|
80 printf "$item: $v0 $v1 $c (%s %s)%s\n", |
|
81 strftime("%FT%T", localtime($v0)), |
|
82 strftime("%FT%T", localtime($v1)), |
|
83 $flag ? " $flag" : ""; |
|
84 } |
|
85 ); |
|
86 print "\n" if @ARGV; |
|
87 } |
|
88 exit 0; |
|
89 } |
|
90 |
|
91 if ($opt_stats) { |
|
92 foreach (@ARGV = getDBs(@ARGV)) { |
|
93 my %h; |
|
94 my $db = connectDB(\%h, $_); |
|
95 |
|
96 my ($seen, $returned, $oldest_c, $oldest_u, $auto); |
|
97 $seen = $returned = 0; |
|
98 $oldest_c = $oldest_u = time(); |
|
99 iterate( |
|
100 %h, |
|
101 sub { |
|
102 my ($item, $v0, $v1, $c, $flags) = @_; |
|
103 if ($flags//'' eq 'auto') { |
|
104 ++$auto; |
|
105 return; |
|
106 } |
|
107 ++$seen; |
|
108 ++$returned if $v0 != $v1; # soon it can be $c |
|
109 $oldest_c = $v0 if $v0 < $oldest_c; |
|
110 $oldest_u = $v1 if $v1 < $oldest_u; |
|
111 return; |
|
112 } |
|
113 ); |
|
114 |
|
115 $_ = <<__; |
|
116 date: %s |
|
117 db: $db (ls: %.1f MB / du: %.1f MB) |
|
118 total: $seen (100%%) |
|
119 returned: %*d (%3d%%) |
|
120 not returned: %*d (%3d%%) |
|
121 auto white listed: %*d |
|
122 oldest (created): %.1f days (%s) |
|
123 oldest (used): %.1f days (%s) |
|
124 __ |
|
125 printf $_, scalar(localtime), (-s $db) / (1024 * 1024), |
|
126 ((stat $db)[12] * 512) / (1024 * 1024), |
|
127 length($seen), $returned, int(0.5 + 100 * ($returned / $seen)), # returned |
|
128 length($seen), $seen - $returned, int(0.5 + 100 * ($seen - $returned) / $seen), # not returned |
|
129 length($seen), $auto, # auto white |
|
130 ((time - $oldest_c) / 86400), scalar(localtime $oldest_c), |
|
131 ((time - $oldest_u) / 86400), scalar(localtime $oldest_u); |
|
132 print "\n" if @ARGV; |
|
133 |
|
134 } |
|
135 exit 0; |
|
136 } |
|
137 |
|
138 if ($opt_clean or $opt_purge) { |
|
139 |
|
140 my $cut = time() - (86400 * (@ARGV ? shift: 7)); |
|
141 foreach (getDBs(@ARGV)) { |
|
142 my %h; |
|
143 my $tmp = tmpfile(); |
|
144 my $db = connectDB(\%h, $_); |
|
145 iterate( |
|
146 %h, |
|
147 sub { |
|
148 my ($item, $v0, $v1, $c) = @_; |
|
149 my $rv = defined $opt_purge ? \$v0 : \$v1; |
|
150 print $tmp "$item\0" if $$rv <= $cut; |
|
151 } |
|
152 ); |
|
153 |
|
154 seek($tmp, 0, 0) or die "Can't seek tmpfile"; |
|
155 |
|
156 $/ = "\0"; |
|
157 delete $h{$_} while <$tmp>; |
|
158 printf "$. items %s from $db\n", $opt_purge ? "purged" : "deleted"; |
|
159 |
|
160 close($tmp); |
|
161 |
|
162 } |
|
163 exit 0; |
|
164 } |
|
165 |
|
166 if ($opt_dbs) { |
|
167 print join("\n", getDBs(@ARGV)), "\n"; |
|
168 exit 0; |
|
169 } |
|
170 |
|
171 if ($opt_insert) { |
|
172 print unseen(@ARGV); |
|
173 exit 0; |
|
174 } |
|
175 |
|
176 if ($opt_remove) { |
|
177 my %default = getDefault(); |
|
178 my $item = shift; |
|
179 my $db = shift // $default{db}; |
|
180 |
|
181 my $key = "$item\0"; |
|
182 |
|
183 connectDB(\my %h, $db); |
|
184 if (not exists $h{$key}) { |
|
185 warn "$0: not found\n"; |
|
186 } |
|
187 else { |
|
188 $_ = $h{$key}; |
|
189 s/\0$/\n/; |
|
190 delete $h{$key}; |
|
191 print; |
|
192 } |
|
193 exit 0; |
|
194 } |
|
195 } |
|
196 |
|
197 sub getDBs(@) { |
|
198 grep { !/\.lock$/ } grep { -f -s } |
|
199 map { m(^\.?/) ? glob($_) : glob(getDBDir() . "/$_") } @_ ? @_ : "*"; |
|
200 } |
|
201 |
|
202 # Helper to iterate over our hash and call the passed |
|
203 # "callback" function (item, v0, v1, count, flags) |
|
204 sub iterate(\%$) { |
|
205 my ($hash, $sub) = @_; |
|
206 while (my ($k, $v) = each %$hash) { |
|
207 chop($k, $v); |
|
208 &$sub($k, (split(' ', $v), 0, 0)[ 0 .. 3 ]); # 0 for filling |
|
209 } |
|
210 } |
|
211 |
|
212 # vim:ft=perl aw sts=4 sw=4: |
|