Add Qpsmtpd::DB testing and more greylist testing

.gitignore

@@ -17,6 +17,8 @@ denysoft_greylist.dbm
 denysoft_greylist.dbm.lock
 greylist.dbm
 greylist.dbm.lock
+greylisting.dbm
+greylisting.dbm.lock
 
 /cover_db/
 .last_cover_stats

lib/Qpsmtpd/DB.pm

@@ -1,20 +1,21 @@
 package Qpsmtpd::DB;
 use strict;
 use warnings;
-use Qpsmtpd::DB::File::DBM;
-use Qpsmtpd::DB::Redis;
+
+our @child_classes = qw(
+    Qpsmtpd::DB::Redis
+    Qpsmtpd::DB::File::DBM
+);
 
 sub new {
     my ( $class, %arg ) = @_;
-    # Qpsmtpd::DB::File::DBM is the only supported class just now
-    my @child_classes = qw(
-        Qpsmtpd::DB::Redis
-        Qpsmtpd::DB::File::DBM
-    );
-    my $manual_class = delete $arg{class};
-    return $manual_class->new(%arg) if $manual_class;
+    my @try_classes = @child_classes;
+    if ( my $manual_class = delete $arg{class} ) {
+        @try_classes = ( $manual_class );
+    }
     my ( $child, @errors );
-    for my $child_class ( @child_classes ) {
+    for my $child_class ( @try_classes ) {
+        eval "use $child_class";
         eval {
             $child = $child_class->new(%arg);
         };

lib/Qpsmtpd/DB/File.pm

@@ -3,11 +3,6 @@ use strict;
 use warnings;
 use parent 'Qpsmtpd::DB';
 
-sub new {
-    my ( $class, %arg ) = @_;
-    return bless { %arg }, $class;
-}
-
 sub dir {
     my ( $self, @candidate_dirs ) = @_;
     return $self->{dir} if $self->{dir} and ! @candidate_dirs;

lib/Qpsmtpd/DB/File/DBM.pm

@@ -8,6 +8,11 @@ BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) }
 use AnyDBM_File;
 use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB);
 
+sub new {
+    my ( $class, %arg ) = @_;
+    return bless {%arg}, $class;
+}
+
 sub file_extension {
     my ( $self, $extension ) = @_;
     return $self->{file_extension} ||= '.dbm';
@@ -152,4 +157,14 @@ sub delete {
     delete $tied->{$key};
 }
 
+sub flush {
+    my ( $self ) = @_;
+    my $tied = $self->{tied};
+    if ( ! $tied ) {
+        warn "DBM db not yet set up, flush() failed\n";
+        return;
+    }
+    delete $tied->{$_} for keys %$tied;
+}
+
 1;

lib/Qpsmtpd/DB/Redis.pm

@@ -107,6 +107,8 @@ sub delete {
     return $self->redis->del($key);
 }
 
+sub flush { shift->redis->flushdb }
+
 package MyRedis;
 eval "use parent 'Redis'";
 

t/plugin_tests/greylisting

@@ -8,11 +8,6 @@ use Qpsmtpd::Constants;
 
 my $test_email = 'user@example.com';
 
-my @greydbs = qw( denysoft_greylist.dbm denysoft_greylist.dbm.lock );
-foreach ( @greydbs ) {
-    unlink $_ if -f $_;
-}
-
 sub register_tests {
     my $self = shift;
 
@@ -238,6 +233,16 @@ sub test_greylist {
     $self->connection->remote_ip('1.2.3.4');
     my $sender = Qpsmtpd::Address->new( "<$test_email>" );
     my $rcpt   = Qpsmtpd::Address->new( "<$test_email>" );
+    for my $test_class (@Qpsmtpd::DB::child_classes) {
+        delete $self->{db};
+        eval { $self->db( class => $test_class ) };
+        if ( $@ ) {
+            warn "Unable to test greylisting against $test_class: $@";
+            next;
+        }
+        $self->db->lock;
+        $self->db->flush;
+        $self->db->unlock;
         my $start = time() - 40 * 3600 * 24; # 40 days ago
         $mocktime = $start;
         is( $self->rc( $self->greylist( $self->transaction, $sender, $rcpt ) ),
@@ -256,6 +261,10 @@ sub test_greylist {
         is( $self->rc( $self->greylist( $self->transaction, $sender, $rcpt ) ),
             'DENYSOFT: This mail is temporarily denied',
             're-greylisted 36 days later' );
+        $self->db->lock;
+        $self->db->flush;
+        $self->db->unlock;
+    }
 }
 
 {

t/qpsmtpd-db-file.t

@@ -0,0 +1,47 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib 'lib';    # test lib/Qpsmtpd (vs site_perl)
+use lib 't';
+
+use_ok('Qpsmtpd::DB::File');
+
+__qphome();
+__validate_dir();
+__dir();
+
+done_testing();
+
+sub __qphome {
+    my $db = FakeDB->new;
+    is( $db->qphome, 't', 'qphome()' );
+}
+
+sub __validate_dir {
+    my $db = FakeDB->new;
+    is( $db->validate_dir(),      0, 'validate_dir(): false on no input' );
+    is( $db->validate_dir(undef), 0, 'validate_dir(): false on undef' );
+    is( $db->validate_dir('invalid'), 0,
+        'validate_dir(): false for non-existent directory' );
+    is( $db->validate_dir('t/config'), 1,
+        'validate_dir(): true for real directory' );
+}
+
+sub __dir {
+    my $db = FakeDB->new;
+    is( $db->dir(), 't/config', 'default directory' );
+    is( $db->dir('_invalid','t/Test'), 't/Test', 'skip invalid candidate dirs' );
+    $db->{dir} = '_cached';
+    is( $db->dir(), '_cached', 'cached directory' );
+    is( $db->dir('t/Test'), 't/Test', 'passing candidate dirs resets cache' );
+    is( $db->dir('_invalid'), 't/config', 'invalid candidate dirs reverts to default' );
+}
+
+package FakeDB;
+use parent 'Qpsmtpd::DB::File';
+sub new {
+    my $class = shift;
+    return bless {@_}, $class;
+}

t/qpsmtpd-db.t

@@ -0,0 +1,68 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib 'lib';    # test lib/Qpsmtpd (vs site_perl)
+use lib 't';
+
+use_ok('Qpsmtpd::DB');
+use_ok('Qpsmtpd');
+
+__new();
+__lock();
+__unlock();
+__name();
+
+done_testing();
+
+sub __new {
+    @Qpsmtpd::DB::child_classes = qw(
+        BrokenClassOne
+        BrokenClassTwo
+    );
+    my $db;
+    eval { $db = Qpsmtpd::DB->new };
+    is( $@, "Couldn't load any storage modules\n"
+          . "Couldn't load BrokenClassOne: fool me once, shame on me\n\n"
+          . "Couldn't load BrokenClassTwo: fool me can't get fooled again\n",
+        'Detect failure to load all child DB classes' );
+    eval { $db = Qpsmtpd::DB->new( class => 'BrokenClassOne' ) };
+    is( $@, "fool me once, shame on me\n",
+        'Failure to load manual class' );
+    @Qpsmtpd::DB::child_classes = qw( EmptyClass );
+    eval { $db = Qpsmtpd::DB->new };
+    is( ref $db, 'EmptyClass',
+        'Load object with manual (bogus) class: Qpsmtpd object is returned' );
+}
+
+sub __lock {
+    @Qpsmtpd::DB::child_classes = qw( EmptyClass );
+    is( Qpsmtpd::DB->new->lock, 1, 'Default lock() method just returns true' );
+}
+
+sub __unlock {
+    @Qpsmtpd::DB::child_classes = qw( EmptyClass );
+    is( Qpsmtpd::DB->new->unlock, 1, 'Default lock() method just returns true' );
+}
+
+sub __name {
+    @Qpsmtpd::DB::child_classes = qw( EmptyClass );
+    my $db = Qpsmtpd::DB->new;
+    is( $db->name,          undef, 'no name set yet' );
+    is( $db->name('test'), 'test', 'set name' );
+    is( $db->name,         'test', 'get name' );
+}
+
+package BrokenClassOne;
+sub new { die "fool me once, shame on me\n" }
+
+package BrokenClassTwo;
+sub new { die "fool me can't get fooled again\n" }
+
+package EmptyClass;
+use parent 'Qpsmtpd::DB';
+sub new {
+    my $class = shift;
+    return bless {@_}, $class;
+}

t/qpsmtpd-plugin.t

@@ -0,0 +1,34 @@
+use strict;
+use warnings;
+
+use Test::More;
+
+use lib 'lib';    # test lib/Qpsmtpd (vs site_perl)
+use lib 't';
+
+use_ok('Qpsmtpd::Plugin');
+
+__db();
+
+done_testing();
+
+sub __db {
+    my $plugin = FakePlugin->new;
+    my $db = $plugin->db( class => 'FakeDB', name => 'testfoo' );
+    is( ref $db, 'FakeDB', 'Qpsmtpd::Plugin::db(): Returns DB object' );
+    is( ref $plugin->{db}, 'FakeDB', 'DB object is cached' );
+    is( $db->{name}, 'testfoo', 'accepts name argument' );
+    delete $plugin->{db};
+    $db = $plugin->db( class => 'FakeDB' );
+    is( $db->{name}, 'testbar', 'name argument defaults to plugin name' );
+}
+
+package FakePlugin;
+use parent 'Qpsmtpd::Plugin';
+sub plugin_name { 'testbar' }
+
+package FakeDB;
+sub new {
+    my $class = shift;
+    return bless {@_}, $class;
+}