156 lines
3.3 KiB
Perl
156 lines
3.3 KiB
Perl
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);
|
|
|
|
sub file_extension {
|
|
my ( $self, $extension ) = @_;
|
|
return $self->{file_extension} ||= '.dbm';
|
|
}
|
|
|
|
sub lock {
|
|
my ( $self ) = @_;
|
|
if ( $self->nfs_locking ) {
|
|
$self->nfs_file_lock or return;
|
|
} else {
|
|
$self->file_lock or return;
|
|
}
|
|
return $self->tie_dbm;
|
|
}
|
|
|
|
sub file_lock {
|
|
my ( $self ) = @_;
|
|
my $path = $self->path;
|
|
open(my $lock, '>', "$path.lock") or do {
|
|
warn "opening lockfile failed: $!\n";
|
|
return;
|
|
};
|
|
|
|
flock($lock, LOCK_EX) or do {
|
|
warn "flock of lockfile failed: $!\n";
|
|
close $lock;
|
|
return;
|
|
};
|
|
$self->{lock} = $lock;
|
|
}
|
|
|
|
sub nfs_file_lock {
|
|
my ( $self ) = @_;
|
|
my $path = $self->path;
|
|
|
|
require File::NFSLock;
|
|
|
|
### set up a lock - lasts until object looses scope
|
|
my $nfslock = new File::NFSLock {
|
|
file => "$path.lock",
|
|
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;
|
|
};
|
|
|
|
open(my $lock, '+<', "$path.lock") or do {
|
|
warn "opening nfs lockfile failed: $!\n";
|
|
return;
|
|
};
|
|
|
|
$self->{lock} = $lock;
|
|
}
|
|
|
|
sub tie_dbm {
|
|
my ( $self ) = @_;
|
|
my $path = $self->path;
|
|
|
|
tie(my %db, 'AnyDBM_File', $path, O_CREAT | O_RDWR, oct('0600')) or do {
|
|
warn "tie to database $path failed: $!\n";
|
|
$self->unlock;
|
|
return;
|
|
};
|
|
$self->{tied} = \%db;
|
|
return 1;
|
|
}
|
|
|
|
sub nfs_locking {
|
|
my $self = shift;
|
|
return $self->{nfs_locking} if ! @_;
|
|
return $self->{nfs_locking} = shift;
|
|
}
|
|
|
|
sub unlock {
|
|
my ( $self ) = @_;
|
|
close $self->{lock};
|
|
untie $self->{tied};
|
|
}
|
|
|
|
sub get {
|
|
my ( $self, $key ) = @_;
|
|
if ( ! $key ) {
|
|
warn "No key provided, set() failed\n";
|
|
return;
|
|
}
|
|
my $tied = $self->{tied};
|
|
if ( ! $tied ) {
|
|
warn "DBM db not yet set up, get() failed\n";
|
|
return;
|
|
}
|
|
return $tied->{$key};
|
|
}
|
|
|
|
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};
|
|
}
|
|
|
|
1;
|