# HG changeset patch
# User heiko
# Date 1464729608 -7200
# Node ID 27440e1334b7393658ea1d9e233f2abcc99c7076
# Parent  9db6f9fdba129f407090ea795015da1b608c9adf
Use lib/ and ExtUtils::MakeMaker

diff -r 9db6f9fdba12 -r 27440e1334b7 .hgignore
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/.hgignore	Tue May 31 23:20:08 2016 +0200
@@ -0,0 +1,5 @@
+_build/
+blib/
+pm_to_blib
+MYMETA.json
+MYMETA.yml
diff -r 9db6f9fdba12 -r 27440e1334b7 Makefile
--- a/Makefile	Tue May 24 17:24:04 2016 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,36 +0,0 @@
-# $Id$
-# $URL$
-#
-PERL = $(shell which perl)
-
-exim = exim
-prefix = /usr/local
-sbindir = ${prefix}/sbin
-libdir = ${prefix}/share/${exim}
-
-SCRIPTS = exigrey
-
-.PHONY:	all clean install
-
-all:	$(SCRIPTS)
-
-clean:
-	-rm -f $(SCRIPTS)
-
-install: all
-	install -m 0755 -d $(DESTDIR)${sbindir}
-	install -m 0755 $(SCRIPTS) $(DESTDIR)${sbindir}/
-
-	install -m 0755 -d $(DESTDIR)$(libdir)
-	install -m 0644 exim-exigrey.pl $(DESTDIR)$(libdir)/exigrey.pl
-
-%:	.%.pl
-	@test -e $@ && { test -w $@ || chmod +w $@; } || true
-	@cat $< >$@
-	@chmod a-w,a+x $@
-
-.%.pl:	%.pl
-	@sed -e 's,@LIBDIR@,$(libdir),g' \
-	     -e	's,@PERL@,$(PERL),g' \
-	<$< >$@
-	@perl -c $@
diff -r 9db6f9fdba12 -r 27440e1334b7 Makefile.PL
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/Makefile.PL	Tue May 31 23:20:08 2016 +0200
@@ -0,0 +1,13 @@
+use ExtUtils::MakeMaker;
+
+WriteMakefile(
+	NAME => 'Exim::Grey',
+	AUTHOR => ['Heiko Schlittermann <hs@schlittermann.de>'],
+	VERSION_FROM => 'lib/Exim/Grey.pm',
+	EXE_FILES => ['bin/exigrey'],
+	PREREQ_PM => {
+		'DB_File::Lock' => '0.05',
+	},
+	NO_META => 1,
+	NO_MYMETA => 1,
+);
diff -r 9db6f9fdba12 -r 27440e1334b7 bin/exigrey
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/bin/exigrey	Tue May 31 23:20:08 2016 +0200
@@ -0,0 +1,208 @@
+#!perl
+# © 2006,2007,2016 Heiko Schlittermann <hs@schlittermann.de>
+# Quick and dirty. Absolutly no warranty. Not even for spelling ;-)
+
+use constant USAGE => <<'#';
+
+Usage: !ME! --insert item [delay [db]]	# insert an item
+       !ME! --remove item               # remove an item
+       !ME! --list [db]			# list all items
+       !ME! --stat [db* ...]		# print short statistic
+       !ME! --clean [days [db* ...]]	# remove items not used since <days> days
+       !ME! --purge [days [db* ...]]	# remove items older than <days> days
+       !ME! --dbs [db* ...]		# list data base(s)
+
+       db  -- single name of database
+       db* -- glob pattern of database
+
+       If the data base name doesn't doesn't start with "./" or "/"
+       it is considered to be realtiv to exim_spool_dir/grey/.
+
+#
+
+use strict;
+use warnings;
+use Getopt::Long;
+use File::Basename;
+use File::Temp qw/tmpfile/;
+use constant ME => basename $0;
+use FindBin qw/$Bin/;
+use POSIX qw/strftime mktime/;
+
+use Exim::Grey qw(:all);
+
+my  $VERSION = '$Id$';
+
+my $opt_list;
+my $opt_stats;
+my $opt_insert;
+my $opt_help;
+my $opt_clean;
+my $opt_purge;
+my $opt_dbs;
+my $opt_remove;
+
+sub getDBs(@);
+sub iterate(\%$);
+
+MAIN: {
+
+    GetOptions(
+        "list!"   => \$opt_list,
+        "insert!" => \$opt_insert,
+	"remove!" => \$opt_remove,
+        "stats!"  => \$opt_stats,
+        "clean!"  => \$opt_clean,
+        "purge!"  => \$opt_purge,
+        "dbs!"    => \$opt_dbs,
+        "help!"   => \$opt_help,
+    ) or die ME . ": Bad usage, try " . ME . " --help.\n";
+
+    if ($opt_help) {
+        ($_ = USAGE) =~ s/!(.*?)!/eval $1/eg;
+        print;
+        exit 0;
+    }
+
+    if ($opt_list) {
+        foreach (@ARGV = getDBs(@ARGV)) {
+            my %h;
+            my $db = connectDB(\%h, $_);
+            print "# $db\n";
+            iterate(
+                %h,
+                sub {
+                    my ($item, $v0, $v1, $c, $flag) = @_;
+                    printf "$item: $v0 $v1 $c (%s %s)%s\n",
+                      strftime("%FT%T", localtime($v0)),
+                      strftime("%FT%T", localtime($v1)),
+		      $flag ? " $flag" : "";
+                }
+            );
+            print "\n" if @ARGV;
+        }
+        exit 0;
+    }
+
+    if ($opt_stats) {
+        foreach (@ARGV = getDBs(@ARGV)) {
+            my %h;
+            my $db = connectDB(\%h, $_);
+
+            my ($seen, $returned, $oldest_c, $oldest_u, $auto);
+            $seen     = $returned = 0;
+            $oldest_c = $oldest_u = time();
+            iterate(
+                %h,
+                sub {
+                    my ($item, $v0, $v1, $c, $flags) = @_;
+		    if ($flags//'' eq 'auto') {
+			++$auto;
+			return;
+		    }
+		    ++$seen;
+		    ++$returned if $v0 != $v1;    # soon it can be $c
+		    $oldest_c = $v0 if $v0 < $oldest_c;
+		    $oldest_u = $v1 if $v1 < $oldest_u;
+		    return;
+                }
+            );
+
+            $_ = <<__;
+ 	     date: %s
+ 	       db: $db (ls: %.1f MB / du: %.1f MB)
+ 	    total: $seen (100%%)
+         returned: %*d (%3d%%)
+     not returned: %*d (%3d%%)
+auto white listed: %*d
+ oldest (created): %.1f days (%s)
+    oldest (used): %.1f days (%s)
+__
+            printf $_, scalar(localtime), (-s $db) / (1024 * 1024),
+              ((stat $db)[12] * 512) / (1024 * 1024), 
+              length($seen), $returned,	int(0.5 + 100 * ($returned / $seen)),                 # returned
+              length($seen), $seen - $returned, int(0.5 + 100 * ($seen - $returned) / $seen), # not returned
+	      length($seen), $auto,							      # auto white
+              ((time - $oldest_c) / 86400), scalar(localtime $oldest_c),
+              ((time - $oldest_u) / 86400), scalar(localtime $oldest_u);
+            print "\n" if @ARGV;
+
+        }
+        exit 0;
+    }
+
+    if ($opt_clean or $opt_purge) {
+
+        my $cut = time() - (86400 * (@ARGV ? shift: 7));
+        foreach (getDBs(@ARGV)) {
+            my %h;
+            my $tmp = tmpfile();
+            my $db = connectDB(\%h, $_);
+            iterate(
+                %h,
+                sub {
+                    my ($item, $v0, $v1, $c) = @_;
+                    my $rv = defined $opt_purge ? \$v0 : \$v1;
+                    print $tmp "$item\0" if $$rv <= $cut;
+                }
+            );
+
+            seek($tmp, 0, 0) or die "Can't seek tmpfile";
+
+            $/ = "\0";
+            delete $h{$_} while <$tmp>;
+            printf "$. items %s from $db\n", $opt_purge ? "purged" : "deleted";
+
+            close($tmp);
+
+        }
+        exit 0;
+    }
+
+    if ($opt_dbs) {
+        print join("\n", getDBs(@ARGV)), "\n";
+        exit 0;
+    }
+
+    if ($opt_insert) {
+        print unseen(@ARGV);
+        exit 0;
+    }
+
+    if ($opt_remove) {
+	my %default = getDefault();
+	my $item = shift;
+	my $db = shift // $default{db};
+
+	my $key = "$item\0";
+
+	connectDB(\my %h, $db);
+	if (not exists $h{$key}) {
+	    warn "$0: not found\n";
+	}
+	else {
+	    $_ = $h{$key};
+	    s/\0$/\n/;
+	    delete $h{$key};
+	    print;
+	}
+	exit 0;
+    }
+}
+
+sub getDBs(@) {
+    grep { !/\.lock$/ } grep { -f -s }
+      map { m(^\.?/) ? glob($_) : glob(getDBDir() . "/$_") } @_ ? @_ : "*";
+}
+
+# Helper to iterate over our hash and call the passed
+# "callback" function (item, v0, v1, count, flags)
+sub iterate(\%$) {
+    my ($hash, $sub) = @_;
+    while (my ($k, $v) = each %$hash) {
+        chop($k, $v);
+        &$sub($k, (split(' ', $v), 0, 0)[ 0 .. 3 ]);    # 0 for filling
+    }
+}
+
+# vim:ft=perl aw sts=4 sw=4:
diff -r 9db6f9fdba12 -r 27440e1334b7 exigrey.pl
--- a/exigrey.pl	Tue May 24 17:24:04 2016 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,212 +0,0 @@
-#! @PERL@
-# © 2006,2007 Heiko Schlittermann <hs@schlittermann.de>
-# Quick and dirty. Absolutly no warranty. Not even for spelling ;-)
-# $Id$
-# $URL$
-
-use constant USAGE => <<'#';
-
-Usage: !ME! --insert item [delay [db]]	# insert an item
-       !ME! --remove item               # remove an item
-       !ME! --list [db]			# list all items
-       !ME! --stat [db* ...]		# print short statistic
-       !ME! --clean [days [db* ...]]	# remove items not used since <days> days
-       !ME! --purge [days [db* ...]]	# remove items older than <days> days
-       !ME! --dbs [db* ...]		# list data base(s)
-
-       db  -- single name of database
-       db* -- glob pattern of database
-
-       If the data base name doesn't doesn't start with "./" or "/"
-       it is considered to be realtiv to exim_spool_dir/grey/.
-
-#
-
-use strict;
-use warnings;
-use Getopt::Long;
-use File::Basename;
-use File::Temp qw/tmpfile/;
-use constant ME => basename $0;
-use FindBin qw/$Bin/;
-use POSIX qw/strftime mktime/;
-
-do './exim-exigrey.pl'
-  or do '@LIBDIR@/exigrey.pl'
-  or die $!;
-
-my $VERSION = '$Id$';
-
-my $opt_list;
-my $opt_stats;
-my $opt_insert;
-my $opt_help;
-my $opt_clean;
-my $opt_purge;
-my $opt_dbs;
-my $opt_remove;
-
-sub getDBs(@);
-sub iterate(\%$);
-
-MAIN: {
-
-    GetOptions(
-        "list!"   => \$opt_list,
-        "insert!" => \$opt_insert,
-	"remove!" => \$opt_remove,
-        "stats!"  => \$opt_stats,
-        "clean!"  => \$opt_clean,
-        "purge!"  => \$opt_purge,
-        "dbs!"    => \$opt_dbs,
-        "help!"   => \$opt_help,
-    ) or die ME . ": Bad usage, try " . ME . " --help.\n";
-
-    if ($opt_help) {
-        ($_ = USAGE) =~ s/!(.*?)!/eval $1/eg;
-        print;
-        exit 0;
-    }
-
-    if ($opt_list) {
-        foreach (@ARGV = getDBs(@ARGV)) {
-            my %h;
-            my $db = connectDB(\%h, $_);
-            print "# $db\n";
-            iterate(
-                %h,
-                sub {
-                    my ($item, $v0, $v1, $c, $flag) = @_;
-                    printf "$item: $v0 $v1 $c (%s %s)%s\n",
-                      strftime("%FT%T", localtime($v0)),
-                      strftime("%FT%T", localtime($v1)),
-		      $flag ? " $flag" : "";
-                }
-            );
-            print "\n" if @ARGV;
-        }
-        exit 0;
-    }
-
-    if ($opt_stats) {
-        foreach (@ARGV = getDBs(@ARGV)) {
-            my %h;
-            my $db = connectDB(\%h, $_);
-
-            my ($seen, $returned, $oldest_c, $oldest_u, $auto);
-            $seen     = $returned = 0;
-            $oldest_c = $oldest_u = time();
-            iterate(
-                %h,
-                sub {
-                    my ($item, $v0, $v1, $c, $flags) = @_;
-		    if ($flags//'' eq 'auto') {
-			++$auto;
-			return;
-		    }
-		    ++$seen;
-		    ++$returned if $v0 != $v1;    # soon it can be $c
-		    $oldest_c = $v0 if $v0 < $oldest_c;
-		    $oldest_u = $v1 if $v1 < $oldest_u;
-		    return;
-                }
-            );
-
-            $_ = <<__;
- 	     date: %s
- 	       db: $db (ls: %.1f MB / du: %.1f MB)
- 	    total: $seen (100%%)
-         returned: %*d (%3d%%)
-     not returned: %*d (%3d%%)
-auto white listed: %*d
- oldest (created): %.1f days (%s)
-    oldest (used): %.1f days (%s)
-__
-            printf $_, scalar(localtime), (-s $db) / (1024 * 1024),
-              ((stat $db)[12] * 512) / (1024 * 1024), 
-              length($seen), $returned,	int(0.5 + 100 * ($returned / $seen)),                 # returned
-              length($seen), $seen - $returned, int(0.5 + 100 * ($seen - $returned) / $seen), # not returned
-	      length($seen), $auto,							      # auto white
-              ((time - $oldest_c) / 86400), scalar(localtime $oldest_c),
-              ((time - $oldest_u) / 86400), scalar(localtime $oldest_u);
-            print "\n" if @ARGV;
-
-        }
-        exit 0;
-    }
-
-    if ($opt_clean or $opt_purge) {
-
-        my $cut = time() - (86400 * (@ARGV ? shift: 7));
-        foreach (getDBs(@ARGV)) {
-            my %h;
-            my $tmp = tmpfile();
-            my $db = connectDB(\%h, $_);
-            iterate(
-                %h,
-                sub {
-                    my ($item, $v0, $v1, $c) = @_;
-                    my $rv = defined $opt_purge ? \$v0 : \$v1;
-                    print $tmp "$item\0" if $$rv <= $cut;
-                }
-            );
-
-            seek($tmp, 0, 0) or die "Can't seek tmpfile";
-
-            $/ = "\0";
-            delete $h{$_} while <$tmp>;
-            printf "$. items %s from $db\n", $opt_purge ? "purged" : "deleted";
-
-            close($tmp);
-
-        }
-        exit 0;
-    }
-
-    if ($opt_dbs) {
-        print join("\n", getDBs(@ARGV)), "\n";
-        exit 0;
-    }
-
-    if ($opt_insert) {
-        print unseen(@ARGV);
-        exit 0;
-    }
-
-    if ($opt_remove) {
-	my %default = getDefault();
-	my $item = shift;
-	my $db = shift // $default{db};
-
-	my $key = "$item\0";
-
-	connectDB(\my %h, $db);
-	if (not exists $h{$key}) {
-	    warn "$0: not found\n";
-	}
-	else {
-	    $_ = $h{$key};
-	    s/\0$/\n/;
-	    delete $h{$key};
-	    print;
-	}
-	exit 0;
-    }
-}
-
-sub getDBs(@) {
-    grep { !/\.lock$/ } grep { -f -s }
-      map { m(^\.?/) ? glob($_) : glob(getDBDir() . "/$_") } @_ ? @_ : "*";
-}
-
-# Helper to iterate over our hash and call the passed
-# "callback" function (item, v0, v1, count, flags)
-sub iterate(\%$) {
-    my ($hash, $sub) = @_;
-    while (my ($k, $v) = each %$hash) {
-        chop($k, $v);
-        &$sub($k, (split(' ', $v), 0, 0)[ 0 .. 3 ]);    # 0 for filling
-    }
-}
-
-# vim:ft=perl aw sts=4 sw=4:
diff -r 9db6f9fdba12 -r 27440e1334b7 exim-exigrey.pl
--- a/exim-exigrey.pl	Tue May 24 17:24:04 2016 +0200
+++ /dev/null	Thu Jan 01 00:00:00 1970 +0000
@@ -1,202 +0,0 @@
-# © 2006,2007,2008 Heiko Schlittermann <hs@schlittermann.de>
-# $Id$
-# $URL$
-
-use strict;
-use warnings;
-use Carp;
-
-# You may choose, but DB_File's footprint is smaller.
-# perl -MDB_File -e 'tie %h, ...':	real    0m0.063s
-# perl -MBerkeleyDB -e 'tie %h, ...':	real	0m0.112s
-# And DB_File is part of the Perl core distribution (?)
-# use BerkeleyDB;
-# use DB_File;
-# But we need locking! DB_File::Lock isn't part of the corelist.
-use DB_File::Lock;
-
-my %DEFAULT = (
-    delay => 600,
-    db    => "seen",
-);
-
-sub unseen;
-
-# some helper functions
-sub getDBDir();
-sub findExim(;$);
-sub connectDB($$);
-sub getDefault() { %DEFAULT }
-
-# Usage:
-# 	${perl{unseen}{KEY}}
-# 	${perl{unseen}{KEY}{600}}
-# 	${perl{unseen}{KEY}{600}{seen}}
-# 	${perl{unseen}{KEY}{600}{$spool_directory/grey/seen}}
-#
-# With KEY being something to identify the second delivery attempt
-# I recommend using <$sender_address>:<$local_part@$domain>
-#
-# If KEY has a /... suffix, this suffix is used for auto-whitelisting.
-# I recommend using $sender_host_address.
-#
-# defer  condition = ${perl{unseen}{<$sender_address>:<$local_part@$domain>/$sender_host_address}}
-#
-# record structure: key:   item\0
-#                   value: timestamp(creation) timestamp(usage)[ auto]\0
-# (This way we're compatible with ${lookup{...}dbm{...}})
-#
-# dbm file is relativ to $spool_directory/grey, EXCEPT its name
-# starts with "./" or "/".
-
-sub unseen {
-    my $item = shift;
-    my $delay = shift // $DEFAULT{delay};
-    my $db = shift // $DEFAULT{db};
-    my $now = time();
-    my ($auto) = $item =~ /.*?\/(.+?)$/;
-    my $rc;
-
-    connectDB(\my %h, $db);
-
-    return 'no'         # not unseen, ergo known
-        if defined $auto and is_whitelisted($auto, \%h);
-
-    my $key = "$item\0";
-
-    # we do not know anything about the client -> unknown
-    if (not exists $h{$key}) {
-        $h{$key} = "$now $now 0\0";
-        return 'yes';
-    }
-
-    my ($created, undef, $count) = split ' ', $h{$key};
-
-    # we know the client, but last contact was recently (too fast)
-    if ($now - $created < $delay) { 
-        return 'yes';
-    }
-
-    # we know the client, was patiently enough
-    ++$count;
-    $h{$key} = "$created $now $count\0";
-    whitelist($auto, \%h) if defined $auto;
-    return 'no';
-}
-
-# According to a thought from "David Woodhouse <dwmw2@infradead.org>"
-# on exim-users@exim.org (Thu, 08 May 2008 13:10:21 +0100, 
-# Message-Id: <1210248621.25560.1088.camel@pmac.infradead.org>) we
-# should have the ability to "auto whitelist" hosts which are known
-# for retries, because there is no benefit in greylisting them.
-#
-# Most safe approach would be something based on message id.
-# If we see the message id a second time it indicates successful retry.
-# But we do not see the message id the first time we reject the message.
-
-# This function has to be called twice per message delivery attempt
-# <KEY> <$sender_host_address> <$sender_helo_name>
-# (Where <KEY> is something like <$sender_address>+<$local_part@$domain>
-# If we see the same message a second time (same message means here:
-# same greylist criteria
-
-sub whitelist {
-    my ($item, $h) = @_;
-    my $now = time;
-    $h->{"$item\0"} = "$now $now 1 auto\0";
-}
-
-sub is_whitelisted {
-    my ($item, $h) = @_;
-    my $key = "$item\0";
-
-    return 0 if not exists $h->{$key};
-    
-    my ($t0, undef, $cnt, $flag) = split ' ', $h->{$key};
-    $h->{$key} = join(' ' => $t0, time, ++$cnt, $flag ? $flag : ()) . "\0";
-
-    return 1;
-}
-
-# Get the directory where we could store the database file(s)
-# If we're running under exim it's easy, otherwise we've to find exim
-# and then ask...
-sub getDBDir() {
-    my ($spooldir, $dbdir);
-    eval { $spooldir = Exim::expand_string('$spool_directory') };
-    if (not defined $spooldir) {
-        my $exim = findExim();
-        chomp($spooldir = `$exim -be '\$spool_directory'`);
-        die "Can't find spooldir" if not defined $spooldir;
-    }
-    -d ($dbdir = "$spooldir/grey") and return $dbdir;
-
-    my ($mode, $owner, $group) = (stat $spooldir)[ 2, 4, 5 ];
-    {
-        local $) = $group;
-        local $> = $owner;
-        $mode &= 0777;
-        mkdir $dbdir, $mode or die "Can't create $dbdir: $!";
-    }
-    return $dbdir;
-}
-
-sub findExim(;$) {
-    my $path = shift || $ENV{PATH};
-    my $exim;
-    foreach (split /:/, $ENV{PATH}) {
-        -x ($exim = "$_/exim")  and return $exim;
-        -x ($exim = "$_/exim4") and return $exim;
-    }
-    die "Can't find exim binary (missing .../sbin dirs in PATH?";
-}
-
-sub connectDB($$) {
-    my ($h, $db) = @_;
-    $db = getDBDir() . "/$db" unless $db =~ m(^\.?/);
-
-    # Creation of DB-File if it doesn't exist
-    # to avoid races we change our own uid/gid for creation of
-    # this file.
-    if (!-f $db) {
-        (my $dir = $db) =~ s/^(.*)\/.*?$/$1/;
-
-        # copy mode, uid, gid from the directory
-        my ($mode, $user, $group) = (stat $dir)[ 2, 4, 5 ]
-          or die "Can't stat $dir: $!";
-        my $umask = umask(($mode & 0777) ^ 0777);
-        local $) = $group;
-        local $> = $user;
-        open(X, ">>$db") or die "Can't create $db: $!";
-        close(X);
-        umask $umask;
-    }
-
-    # now test which of the DB-Modules has been loaded
-
-    if (exists &BerkeleyDB::Hash::TIEHASH) {
-        no strict;
-        my $umask = umask 077;
-        tie %$h, "BerkeleyDB::Hash", -Filename => $db
-          or die "$0: $db: $!";
-        return $db;
-    }
-
-    if (exists &DB_File::Lock::TIEHASH) {
-        tie %$h, 'DB_File::Lock', [ $db ], 'write'
-          or die "$0: $db: $!";
-        return $db;
-    }
-
-    if (exists &DB_File::TIEHASH) {
-        tie %$h, 'DB_File', $db or die "$0: $db: $!";
-        warn "$0: using DB_File, no locking is possible!\n";
-        return $db;
-    }
-
-    die "Can't connect to database driver";
-}
-
-1;
-
-# vim:aw et sw=4 ts=4:
diff -r 9db6f9fdba12 -r 27440e1334b7 lib/Exim/Grey.pm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lib/Exim/Grey.pm	Tue May 31 23:20:08 2016 +0200
@@ -0,0 +1,207 @@
+package Exim::Grey;
+
+use strict;
+use warnings;
+use base 'Exporter';
+use Carp;
+
+our @EXPORT_OK = qw(unseen getDBDir getDBs connectDB);
+our %EXPORT_TAGS = (
+    all => \@EXPORT_OK,
+);
+our $VERSION = '2.0';
+
+# You may choose, but DB_File's footprint is smaller.
+# perl -MDB_File -e 'tie %h, ...':	real    0m0.063s
+# perl -MBerkeleyDB -e 'tie %h, ...':	real	0m0.112s
+# And DB_File is part of the Perl core distribution (?)
+# use BerkeleyDB;
+# use DB_File;
+# But we need locking! DB_File::Lock isn't part of the corelist.
+use DB_File::Lock;
+
+my %DEFAULT = (
+    delay => 600,
+    db    => "seen",
+);
+
+sub unseen;
+
+# some helper functions
+sub getDBDir();
+sub findExim(;$);
+sub connectDB($$);
+sub getDefault() { %DEFAULT }
+
+# Usage:
+# 	${perl{unseen}{KEY}}
+# 	${perl{unseen}{KEY}{600}}
+# 	${perl{unseen}{KEY}{600}{seen}}
+# 	${perl{unseen}{KEY}{600}{$spool_directory/grey/seen}}
+#
+# With KEY being something to identify the second delivery attempt
+# I recommend using <$sender_address>:<$local_part@$domain>
+#
+# If KEY has a /... suffix, this suffix is used for auto-whitelisting.
+# I recommend using $sender_host_address.
+#
+# defer  condition = ${perl{unseen}{<$sender_address>:<$local_part@$domain>/$sender_host_address}}
+#
+# record structure: key:   item\0
+#                   value: timestamp(creation) timestamp(usage)[ auto]\0
+# (This way we're compatible with ${lookup{...}dbm{...}})
+#
+# dbm file is relativ to $spool_directory/grey, EXCEPT its name
+# starts with "./" or "/".
+
+sub unseen {
+    my $item = shift;
+    my $delay = shift // $DEFAULT{delay};
+    my $db = shift // $DEFAULT{db};
+    my $now = time();
+    my ($auto) = $item =~ /.*?\/(.+?)$/;
+    my $rc;
+
+    connectDB(\my %h, $db);
+
+    return 'no'         # not unseen, ergo known
+        if defined $auto and is_whitelisted($auto, \%h);
+
+    my $key = "$item\0";
+
+    # we do not know anything about the client -> unknown
+    if (not exists $h{$key}) {
+        $h{$key} = "$now $now 0\0";
+        return 'yes';
+    }
+
+    my ($created, undef, $count) = split ' ', $h{$key};
+
+    # we know the client, but last contact was recently (too fast)
+    if ($now - $created < $delay) { 
+        return 'yes';
+    }
+
+    # we know the client, was patiently enough
+    ++$count;
+    $h{$key} = "$created $now $count\0";
+    whitelist($auto, \%h) if defined $auto;
+    return 'no';
+}
+
+# According to a thought from "David Woodhouse <dwmw2@infradead.org>"
+# on exim-users@exim.org (Thu, 08 May 2008 13:10:21 +0100, 
+# Message-Id: <1210248621.25560.1088.camel@pmac.infradead.org>) we
+# should have the ability to "auto whitelist" hosts which are known
+# for retries, because there is no benefit in greylisting them.
+#
+# Most safe approach would be something based on message id.
+# If we see the message id a second time it indicates successful retry.
+# But we do not see the message id the first time we reject the message.
+
+# This function has to be called twice per message delivery attempt
+# <KEY> <$sender_host_address> <$sender_helo_name>
+# (Where <KEY> is something like <$sender_address>+<$local_part@$domain>
+# If we see the same message a second time (same message means here:
+# same greylist criteria
+
+sub whitelist {
+    my ($item, $h) = @_;
+    my $now = time;
+    $h->{"$item\0"} = "$now $now 1 auto\0";
+}
+
+sub is_whitelisted {
+    my ($item, $h) = @_;
+    my $key = "$item\0";
+
+    return 0 if not exists $h->{$key};
+    
+    my ($t0, undef, $cnt, $flag) = split ' ', $h->{$key};
+    $h->{$key} = join(' ' => $t0, time, ++$cnt, $flag ? $flag : ()) . "\0";
+
+    return 1;
+}
+
+# Get the directory where we could store the database file(s)
+# If we're running under exim it's easy, otherwise we've to find exim
+# and then ask...
+sub getDBDir() {
+    my ($spooldir, $dbdir);
+    eval { $spooldir = Exim::expand_string('$spool_directory') };
+    if (not defined $spooldir) {
+        my $exim = findExim();
+        chomp($spooldir = `$exim -be '\$spool_directory'`);
+        die "Can't find spooldir" if not defined $spooldir;
+    }
+    -d ($dbdir = "$spooldir/grey") and return $dbdir;
+
+    my ($mode, $owner, $group) = (stat $spooldir)[ 2, 4, 5 ];
+    {
+        local $) = $group;
+        local $> = $owner;
+        $mode &= 0777;
+        mkdir $dbdir, $mode or die "Can't create $dbdir: $!";
+    }
+    return $dbdir;
+}
+
+sub findExim(;$) {
+    my $path = shift || $ENV{PATH};
+    my $exim;
+    foreach (split /:/, $ENV{PATH}) {
+        -x ($exim = "$_/exim")  and return $exim;
+        -x ($exim = "$_/exim4") and return $exim;
+    }
+    die "Can't find exim binary (missing .../sbin dirs in PATH?";
+}
+
+sub connectDB($$) {
+    my ($h, $db) = @_;
+    $db = getDBDir() . "/$db" unless $db =~ m(^\.?/);
+
+    # Creation of DB-File if it doesn't exist
+    # to avoid races we change our own uid/gid for creation of
+    # this file.
+    if (!-f $db) {
+        (my $dir = $db) =~ s/^(.*)\/.*?$/$1/;
+
+        # copy mode, uid, gid from the directory
+        my ($mode, $user, $group) = (stat $dir)[ 2, 4, 5 ]
+          or die "Can't stat $dir: $!";
+        my $umask = umask(($mode & 0777) ^ 0777);
+        local $) = $group;
+        local $> = $user;
+        open(X, ">>$db") or die "Can't create $db: $!";
+        close(X);
+        umask $umask;
+    }
+
+    # now test which of the DB-Modules has been loaded
+
+    if (exists &BerkeleyDB::Hash::TIEHASH) {
+        no strict;
+        my $umask = umask 077;
+        tie %$h, "BerkeleyDB::Hash", -Filename => $db
+          or die "$0: $db: $!";
+        return $db;
+    }
+
+    if (exists &DB_File::Lock::TIEHASH) {
+        tie %$h, 'DB_File::Lock', [ $db ], 'write'
+          or die "$0: $db: $!";
+        return $db;
+    }
+
+    if (exists &DB_File::TIEHASH) {
+        tie %$h, 'DB_File', $db or die "$0: $db: $!";
+        warn "$0: using DB_File, no locking is possible!\n";
+        return $db;
+    }
+
+    die "Can't connect to database driver";
+}
+
+1;
+
+# vim:aw et sw=4 ts=4:
diff -r 9db6f9fdba12 -r 27440e1334b7 t/00-basic.t
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/t/00-basic.t	Tue May 31 23:20:08 2016 +0200
@@ -0,0 +1,3 @@
+use Test::More qw(no_plan);
+
+use_ok 'Exim::Grey' => qw(unseen);