12 # perl -MBerkeleyDB -e 'tie %h, ...': real 0m0.112s |
12 # perl -MBerkeleyDB -e 'tie %h, ...': real 0m0.112s |
13 # And DB_File is part of the Perl core distribution (?) |
13 # And DB_File is part of the Perl core distribution (?) |
14 # use BerkeleyDB; |
14 # use BerkeleyDB; |
15 use DB_File; |
15 use DB_File; |
16 |
16 |
17 my %DEFAULT = ( |
17 my %DEFAULT = (delay => 600, |
18 delay => 600, |
18 db => "seen", |
19 db => "seen", |
19 white => "white", |
20 white => "white", |
|
21 ); |
20 ); |
22 |
21 |
23 sub unseen($;$$); |
22 sub unseen($;$$); |
24 |
23 |
25 # some helper functions |
24 # some helper functions |
26 sub getDBDir(); |
25 sub getDBDir(); |
27 sub findExim(;$); |
26 sub findExim(;$); |
28 sub connectDB($$); |
27 sub connectDB($$); |
29 sub disconnectDB(); |
28 sub disconnectDB(); |
30 sub getDefault() { %DEFAULT }; |
29 sub getDefault() { %DEFAULT } |
31 |
30 |
32 # Usage: |
31 # Usage: |
33 # ${perl{unseen}{$sender_host_address}} |
32 # ${perl{unseen}{$sender_host_address}} |
34 # ${perl{unseen}{$sender_host_address}{600}} |
33 # ${perl{unseen}{$sender_host_address}{600}} |
35 # ${perl{unseen}{$sender_host_address}{600}{seen}} |
34 # ${perl{unseen}{$sender_host_address}{600}{seen}} |
36 # ${perl{unseen}{$sender_host_address}{600}{$spool_directory/grey/seen}} |
35 # ${perl{unseen}{$sender_host_address}{600}{$spool_directory/grey/seen}} |
37 # |
36 # |
38 # record structure: key: item\0 |
37 # record structure: key: item\0 |
39 # value: timestamp(creation) timestamp(usage)\0 |
38 # value: timestamp(creation) timestamp(usage)\0 |
40 # (This way we're compatible with ${lookup{...}dbm{...}}) |
39 # (This way we're compatible with ${lookup{...}dbm{...}}) |
41 # |
40 # |
42 # dbm file is relativ to $spool_directory/grey, EXCEPT its name |
41 # dbm file is relativ to $spool_directory/grey, EXCEPT its name |
43 # starts with "./" or "/". |
42 # starts with "./" or "/". |
44 # |
43 # |
45 sub unseen($;$$) { |
44 sub unseen($;$$) { |
46 my ($item, $delay, $db) = @_; |
45 my ($item, $delay, $db) = @_; |
47 $item .= "\0"; |
46 $item .= "\0"; |
48 $delay = $DEFAULT{delay} unless defined $delay; |
47 $delay = $DEFAULT{delay} unless defined $delay; |
49 $db = $DEFAULT{db} unless defined $db; |
48 $db = $DEFAULT{db} unless defined $db; |
50 |
49 |
51 my $now = time(); |
50 my $now = time(); |
52 my $rc; |
51 my $rc; |
53 |
52 |
54 my %h; |
53 my %h; |
55 $db = connectDB(\%h, $db); |
54 $db = connectDB(\%h, $db); |
56 |
55 |
57 if (not exists $h{$item}) { |
56 if (not exists $h{$item}) { |
58 $h{$item} = "$now $now 0\0"; |
57 $h{$item} = "$now $now 0\0"; |
59 $rc = "yes"; |
58 $rc = "yes"; |
60 } else { |
59 } |
61 ($_ = $h{$item}) =~ s/\0*$//; # we're \0 terminated |
60 else { |
62 my ($created, $used, $count) = split; |
61 ($_ = $h{$item}) =~ s/\0*$//; # we're \0 terminated |
63 if ($now - $created < $delay) { $rc = "yes" } |
62 my ($created, $used, $count) = split; |
64 else { |
63 if ($now - $created < $delay) { $rc = "yes" } |
65 $rc = "no"; |
64 else { |
66 ++$count; |
65 $rc = "no"; |
67 $h{$item} = "$created $now $count\0"; |
66 ++$count; |
68 } |
67 $h{$item} = "$created $now $count\0"; |
69 } |
68 } |
70 untie %h; |
69 } |
71 disconnectDB(); |
70 untie %h; |
72 return $rc; |
71 disconnectDB(); |
|
72 return $rc; |
73 } |
73 } |
74 |
74 |
75 sub white($;$) { |
75 sub white($;$) { |
76 unseen($_[0], 0, defined $_[1] ? $_[1] : $DEFAULT{white}); |
76 unseen($_[0], 0, defined $_[1] ? $_[1] : $DEFAULT{white}); |
77 return "yes"; |
77 return "yes"; |
78 } |
78 } |
79 |
|
80 |
79 |
81 # Get the directory where we could store the database file(s) |
80 # Get the directory where we could store the database file(s) |
82 # If we're running under exim it's easy, otherwise we've to find exim |
81 # If we're running under exim it's easy, otherwise we've to find exim |
83 # and then ask... |
82 # and then ask... |
84 sub getDBDir() { |
83 sub getDBDir() { |
85 my ($spooldir, $dbdir); |
84 my ($spooldir, $dbdir); |
86 eval { $spooldir = Exim::expand_string('$spool_directory') }; |
85 eval { $spooldir = Exim::expand_string('$spool_directory') }; |
87 if (not defined $spooldir) { |
86 if (not defined $spooldir) { |
88 my $exim = findExim(); |
87 my $exim = findExim(); |
89 chomp($spooldir = `$exim -be '\$spool_directory'`); |
88 chomp($spooldir = `$exim -be '\$spool_directory'`); |
90 die "Can't find spooldir" if not defined $spooldir; |
89 die "Can't find spooldir" if not defined $spooldir; |
91 } |
90 } |
92 -d ($dbdir = "$spooldir/grey") and return $dbdir; |
91 -d ($dbdir = "$spooldir/grey") and return $dbdir; |
93 |
92 |
94 my ($mode, $owner, $group) = (stat $spooldir)[2,4,5]; |
93 my ($mode, $owner, $group) = (stat $spooldir)[ 2, 4, 5 ]; |
95 { |
94 { |
96 local $) = $group; |
95 local $) = $group; |
97 local $> = $owner; |
96 local $> = $owner; |
98 $mode &= 0777; |
97 $mode &= 0777; |
99 mkdir $dbdir, $mode or die "Can't create $dbdir: $!"; |
98 mkdir $dbdir, $mode or die "Can't create $dbdir: $!"; |
100 } |
99 } |
101 return $dbdir; |
100 return $dbdir; |
102 } |
101 } |
103 |
102 |
104 sub findExim(;$) { |
103 sub findExim(;$) { |
105 my $path = shift || $ENV{PATH}; |
104 my $path = shift || $ENV{PATH}; |
106 my $exim; |
105 my $exim; |
107 foreach (split /:/, $ENV{PATH}) { |
106 foreach (split /:/, $ENV{PATH}) { |
108 -x ($exim = "$_/exim") and return $exim; |
107 -x ($exim = "$_/exim") and return $exim; |
109 -x ($exim = "$_/exim4") and return $exim; |
108 -x ($exim = "$_/exim4") and return $exim; |
110 } |
109 } |
111 die "Can't find exim binary (missing .../sbin dirs in PATH?"; |
110 die "Can't find exim binary (missing .../sbin dirs in PATH?"; |
112 } |
111 } |
113 |
112 |
114 { |
113 { |
115 my $fh; |
114 my $fh; |
116 sub connectDB($$) { |
|
117 my ($h, $db) = @_; |
|
118 $db = getDBDir() ."/$db" unless $db =~ m(^\.?/); |
|
119 |
115 |
120 # Creation of DB-File if it doesn't exist |
116 sub connectDB($$) { |
121 # to avoid races we change our own uid/gid for creation of |
117 my ($h, $db) = @_; |
122 # this file. |
118 $db = getDBDir() . "/$db" unless $db =~ m(^\.?/); |
123 if (!-f $db) { |
|
124 (my $dir = $db) =~ s/^(.*)\/.*?$/$1/; |
|
125 |
119 |
126 # copy mode, uid, gid from the directory |
120 # Creation of DB-File if it doesn't exist |
127 my ($mode, $user, $group) = (stat $dir)[2,4,5] or die "Can't stat $dir: $!"; |
121 # to avoid races we change our own uid/gid for creation of |
128 my $umask = umask(($mode & 0777) ^ 0777); |
122 # this file. |
129 local $) = $group; |
123 if (!-f $db) { |
130 local $> = $user; |
124 (my $dir = $db) =~ s/^(.*)\/.*?$/$1/; |
131 open(X, ">>$db") or die "Can't create $db: $!"; |
|
132 close(X); |
|
133 umask $umask; |
|
134 } |
|
135 |
125 |
136 # We try to open and lock the database file to avoid |
126 # copy mode, uid, gid from the directory |
137 # a race. |
127 my ($mode, $user, $group) = (stat $dir)[ 2, 4, 5 ] |
138 open($fh, $db) or die "Can't open $db: $!"; |
128 or die "Can't stat $dir: $!"; |
139 flock($fh, LOCK_EX) or die "Can't lock $db: $!"; |
129 my $umask = umask(($mode & 0777) ^ 0777); |
|
130 local $) = $group; |
|
131 local $> = $user; |
|
132 open(X, ">>$db") or die "Can't create $db: $!"; |
|
133 close(X); |
|
134 umask $umask; |
|
135 } |
140 |
136 |
141 # now test which of the DB-Modules has been loaded |
137 # We try to open and lock the database file to avoid |
|
138 # a race. |
|
139 open($fh, $db) or die "Can't open $db: $!"; |
|
140 flock($fh, LOCK_EX) or die "Can't lock $db: $!"; |
142 |
141 |
143 if (exists &BerkeleyDB::Hash::TIEHASH) { |
142 # now test which of the DB-Modules has been loaded |
144 no strict; |
|
145 my $umask = umask 077; |
|
146 tie %$h, "BerkeleyDB::Hash", |
|
147 -Filename => $db |
|
148 or die "$0: $db: $!"; |
|
149 return $db; |
|
150 } |
|
151 |
143 |
152 if (exists &DB_File::TIEHASH) { |
144 if (exists &BerkeleyDB::Hash::TIEHASH) { |
153 tie %$h, "DB_File", $db |
145 no strict; |
154 or die "$0: $db: $!"; |
146 my $umask = umask 077; |
155 return $db; |
147 tie %$h, "BerkeleyDB::Hash", -Filename => $db |
156 } |
148 or die "$0: $db: $!"; |
|
149 return $db; |
|
150 } |
157 |
151 |
158 die "Can't connect to database driver"; |
152 if (exists &DB_File::TIEHASH) { |
|
153 tie %$h, "DB_File", $db |
|
154 or die "$0: $db: $!"; |
|
155 return $db; |
|
156 } |
|
157 |
|
158 die "Can't connect to database driver"; |
|
159 } |
|
160 |
|
161 sub disconnectDB() { |
|
162 close($fh); |
|
163 } |
159 } |
164 } |
160 |
165 0; |
161 sub disconnectDB() { |
|
162 close($fh); |
|
163 } } |
|
164 1; |
|
165 |
166 |
166 # vim:aw: |
167 # vim:aw: |