2014-11-26 00:52:18 +01:00
|
|
|
package Qpsmtpd::DB::File::DBM;
|
|
|
|
use strict;
|
|
|
|
use warnings;
|
|
|
|
|
|
|
|
use parent 'Qpsmtpd::DB::File';
|
|
|
|
|
|
|
|
BEGIN { @AnyDBM_File::ISA = qw(DB_File GDBM_File NDBM_File) }
|
|
|
|
use AnyDBM_File;
|
|
|
|
use Fcntl qw(:DEFAULT :flock LOCK_EX LOCK_NB);
|
|
|
|
|
2014-12-26 07:52:17 +01:00
|
|
|
sub new {
|
|
|
|
my ( $class, %arg ) = @_;
|
|
|
|
return bless {%arg}, $class;
|
|
|
|
}
|
|
|
|
|
2014-11-26 00:52:18 +01:00
|
|
|
sub file_extension {
|
|
|
|
my ( $self, $extension ) = @_;
|
|
|
|
return $self->{file_extension} ||= '.dbm';
|
|
|
|
}
|
|
|
|
|
2014-11-26 23:06:24 +01:00
|
|
|
sub lock {
|
2014-11-26 00:52:18 +01:00
|
|
|
my ( $self ) = @_;
|
2014-11-26 23:28:52 +01:00
|
|
|
if ( $self->nfs_locking ) {
|
|
|
|
$self->nfs_file_lock or return;
|
|
|
|
} else {
|
|
|
|
$self->file_lock or return;
|
|
|
|
}
|
|
|
|
return $self->tie_dbm;
|
2014-11-26 23:06:24 +01:00
|
|
|
}
|
|
|
|
|
|
|
|
sub file_lock {
|
|
|
|
my ( $self ) = @_;
|
|
|
|
my $path = $self->path;
|
|
|
|
open(my $lock, '>', "$path.lock") or do {
|
2014-11-26 00:52:18 +01:00
|
|
|
warn "opening lockfile failed: $!\n";
|
|
|
|
return;
|
|
|
|
};
|
|
|
|
|
|
|
|
flock($lock, LOCK_EX) or do {
|
|
|
|
warn "flock of lockfile failed: $!\n";
|
|
|
|
close $lock;
|
|
|
|
return;
|
|
|
|
};
|
2014-11-26 23:06:24 +01:00
|
|
|
$self->{lock} = $lock;
|
2014-11-26 00:52:18 +01:00
|
|
|
}
|
|
|
|
|
2014-11-26 23:06:24 +01:00
|
|
|
sub nfs_file_lock {
|
2014-11-26 00:52:18 +01:00
|
|
|
my ( $self ) = @_;
|
2014-11-26 23:06:24 +01:00
|
|
|
my $path = $self->path;
|
2014-11-26 00:52:18 +01:00
|
|
|
|
|
|
|
require File::NFSLock;
|
|
|
|
|
|
|
|
### set up a lock - lasts until object looses scope
|
|
|
|
my $nfslock = new File::NFSLock {
|
2014-11-26 23:06:24 +01:00
|
|
|
file => "$path.lock",
|
2014-11-26 00:52:18 +01:00
|
|
|
lock_type => LOCK_EX | LOCK_NB,
|
|
|
|
blocking_timeout => 10, # 10 sec
|
|
|
|
stale_lock_timeout => 30 * 60, # 30 min
|
|
|
|
}
|
|
|
|
or do {
|
|
|
|
warn "nfs lockfile failed: $!\n";
|
|
|
|
return;
|
|
|
|
};
|
|
|
|
|
2014-11-26 23:06:24 +01:00
|
|
|
open(my $lock, '+<', "$path.lock") or do {
|
2014-11-26 00:52:18 +01:00
|
|
|
warn "opening nfs lockfile failed: $!\n";
|
|
|
|
return;
|
|
|
|
};
|
|
|
|
|
2014-11-26 23:06:24 +01:00
|
|
|
$self->{lock} = $lock;
|
|
|
|
}
|
|
|
|
|
|
|
|
sub tie_dbm {
|
|
|
|
my ( $self ) = @_;
|
|
|
|
my $path = $self->path;
|
|
|
|
|
2015-01-04 21:22:15 +01:00
|
|
|
tie(my %db, 'AnyDBM_File', $path, O_CREAT | O_RDWR, oct('0640')) or do {
|
2014-11-26 23:06:24 +01:00
|
|
|
warn "tie to database $path failed: $!\n";
|
|
|
|
$self->unlock;
|
|
|
|
return;
|
|
|
|
};
|
|
|
|
$self->{tied} = \%db;
|
2014-11-26 23:28:52 +01:00
|
|
|
return 1;
|
2014-11-26 00:52:18 +01:00
|
|
|
}
|
|
|
|
|
|
|
|
sub nfs_locking {
|
|
|
|
my $self = shift;
|
|
|
|
return $self->{nfs_locking} if ! @_;
|
|
|
|
return $self->{nfs_locking} = shift;
|
|
|
|
}
|
|
|
|
|
2014-11-26 23:06:24 +01:00
|
|
|
sub unlock {
|
|
|
|
my ( $self ) = @_;
|
|
|
|
close $self->{lock};
|
|
|
|
untie $self->{tied};
|
2015-01-21 23:43:23 +01:00
|
|
|
delete $self->{tied};
|
2014-11-26 23:06:24 +01:00
|
|
|
}
|
|
|
|
|
|
|
|
sub get {
|
|
|
|
my ( $self, $key ) = @_;
|
|
|
|
if ( ! $key ) {
|
2015-01-27 17:59:47 +01:00
|
|
|
warn "No key provided, get() failed\n";
|
2014-11-26 23:06:24 +01:00
|
|
|
return;
|
|
|
|
}
|
|
|
|
my $tied = $self->{tied};
|
|
|
|
if ( ! $tied ) {
|
|
|
|
warn "DBM db not yet set up, get() failed\n";
|
|
|
|
return;
|
|
|
|
}
|
|
|
|
return $tied->{$key};
|
|
|
|
}
|
|
|
|
|
2015-01-27 17:59:47 +01:00
|
|
|
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 }
|
|
|
|
}
|
|
|
|
|
2014-11-26 23:06:24 +01:00
|
|
|
sub set {
|
|
|
|
my ( $self, $key, $val ) = @_;
|
|
|
|
my $tied = $self->{tied};
|
|
|
|
if ( ! $tied ) {
|
|
|
|
warn "DBM db not yet set up, set() failed\n";
|
|
|
|
return;
|
|
|
|
}
|
|
|
|
if ( ! $key ) {
|
|
|
|
warn "No key provided, set() failed\n";
|
|
|
|
return;
|
|
|
|
}
|
|
|
|
return $tied->{$key} = $val;
|
|
|
|
}
|
|
|
|
|
|
|
|
sub get_keys {
|
|
|
|
my ( $self ) = @_;
|
|
|
|
my $tied = $self->{tied};
|
|
|
|
if ( ! $tied ) {
|
|
|
|
warn "DBM db not yet set up, keys() failed\n";
|
|
|
|
return;
|
|
|
|
}
|
|
|
|
return keys %$tied;
|
|
|
|
}
|
|
|
|
|
|
|
|
sub size {
|
|
|
|
my ( $self ) = @_;
|
|
|
|
my $tied = $self->{tied};
|
|
|
|
if ( ! $tied ) {
|
|
|
|
warn "DBM db not yet set up, size() failed\n";
|
|
|
|
return;
|
|
|
|
}
|
|
|
|
return scalar keys %$tied;
|
|
|
|
}
|
|
|
|
|
|
|
|
sub delete {
|
|
|
|
my ( $self, $key ) = @_;
|
|
|
|
my $tied = $self->{tied};
|
|
|
|
if ( ! $tied ) {
|
|
|
|
warn "DBM db not yet set up, delete() failed\n";
|
|
|
|
return;
|
|
|
|
}
|
|
|
|
if ( ! $key ) {
|
|
|
|
warn "No key provided, delete() failed\n";
|
|
|
|
return;
|
|
|
|
}
|
|
|
|
delete $tied->{$key};
|
|
|
|
}
|
|
|
|
|
2014-12-26 07:52:17 +01:00
|
|
|
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;
|
|
|
|
}
|
|
|
|
|
2014-11-26 00:52:18 +01:00
|
|
|
1;
|