Speed up prune_db() with new Qpsmtpd::DB::mget()

This reduces round trips to Redis, speeding up DB pruning,
especially over a network

lib/Qpsmtpd/DB/File/DBM.pm

@@ -99,7 +99,7 @@ sub unlock {
 sub get {
     my ( $self, $key ) = @_;
     if ( ! $key ) {
-        warn "No key provided, set() failed\n";
+        warn "No key provided, get() failed\n";
         return;
     }
     my $tied = $self->{tied};
@@ -110,6 +110,20 @@ sub get {
     return $tied->{$key};
 }
 
+sub mget {
+    my ( $self, @keys ) = @_;
+    if ( ! @keys ) {
+        warn "No key provided, mget() failed\n";
+        return;
+    }
+    my $tied = $self->{tied};
+    if ( ! $tied ) {
+        warn "DBM db not yet set up, mget() failed\n";
+        return;
+    }
+    return @$tied{ @keys }
+}
+
 sub set {
     my ( $self, $key, $val ) = @_;
     my $tied = $self->{tied};

lib/Qpsmtpd/DB/Redis.pm

@@ -72,6 +72,15 @@ sub get {
     return $self->redis->get($key);
 }
 
+sub mget {
+    my ( $self, @keys ) = @_;
+    if ( ! @keys ) {
+        warn "No key provided, mget() failed\n";
+        return;
+    }
+    return $self->redis->mget(@keys);
+}
+
 sub set {
     my ( $self, $key, $val ) = @_;
     if ( ! $key ) {

plugins/greylisting

@@ -486,12 +486,15 @@ sub convert_db {
 sub prune_db {
     my $self = shift;
 
-    $self->db->lock or return DECLINED;
+    $self->db->lock or return;
     my $count = $self->db->size;
 
     my $pruned = 0;
-    foreach my $key ( $self->db->get_keys ) {
-        my ($ts, $new, $black, $white) = split /:/, $self->db->get($key);
+    my $greylist = {};
+    my @keys = $self->db->get_keys or return;
+    @$greylist{ @keys } = ( $self->db->mget(@keys) );
+    for my $key ( @keys ) {
+        my ($ts) = split /:/, delete $greylist->{$key};
         my $age = $self->now - $ts;
         next if $age < $self->{_args}{white_timeout};
         $pruned++;
@@ -499,7 +502,6 @@ sub prune_db {
     }
     $self->db->unlock;
     $self->log(LOGINFO, "pruned $pruned of $count DB entries");
-    return DECLINED;
 }
 
 sub exclude {

t/qpsmtpd-db-file-dbm.t

@@ -11,6 +11,7 @@ use_ok('Qpsmtpd::DB::File::DBM');
 my $db = Qpsmtpd::DB::File::DBM->new( name => 'testing' );
 __new();
 __get();
+__mget();
 __set();
 __delete();
 __get_keys();
@@ -32,6 +33,16 @@ sub __get {
     $db->unlock;
 }
 
+sub __mget {
+    $db->lock;
+    $db->flush;
+    $db->set( key1 => 'val1' );
+    $db->set( key2 => 'val2' );
+    is( join('|',$db->mget(qw( key2 key1 ))), 'val2|val1',
+        'mget() retrieves multiple keys' );
+    $db->unlock;
+}
+
 sub __set {
     $db->lock;
     $db->flush;
@@ -89,7 +100,10 @@ sub __untie_gotcha {
     $db2->lock;
     is( $db2->get('cut'), 'itout',
         'get() in second db handle reads key set in first handle' );
-    $db2->unlock;
-    $db->flush;
+    # Get rid of test data
     $db2->flush;
+    $db2->unlock;
+    $db->lock;
+    $db->flush;
+    $db->unlock;
 }

t/qpsmtpd-db-redis.t

@@ -25,6 +25,7 @@ else {
 __index();
 __redis();
 __get();
+__mget();
 __set();
 __delete();
 __get_keys();
@@ -93,6 +94,15 @@ sub __get {
     is( $db->get('moo'), 'oooo', 'get() retrieves key' );
 }
 
+sub __mget {
+    my $redis = $db->redis;
+    $redis->flushdb;
+    $redis->set( key1 => 'val1' );
+    $redis->set( key2 => 'val2' );
+    is( join('|',$db->mget(qw( key2 key1 ))), 'val2|val1',
+        'mget() retrieves multiple keys' );
+}
+
 sub __set {
     my $redis = $db->redis;
     $redis->flushdb;
@@ -150,6 +160,12 @@ sub get      { $_[0]->fakestore->{ $_[1] }         }
 sub set      { $_[0]->fakestore->{ $_[1] } = $_[2] }
 sub del      { delete $_[0]->fakestore->{ $_[1] }  }
 
+sub mget {
+    my ($self,@keys) = @_;
+    my $f = $self->fakestore;
+    return @$f{ @keys };
+}
+
 sub hgetall  {
     my ( $self, $h ) = @_;
     return %{ $self->fakestore->{ $h } || {} };