package Bot::Cobalt::DB;
$Bot::Cobalt::DB::VERSION = '0.021003';
## Uses proper retie-after-lock technique for locking
use v5.10;
use strictures 2;
use Carp;
use List::Objects::WithUtils;
use DB_File;
use Fcntl qw/:DEFAULT :flock/;
use IO::File;
use Bot::Cobalt::Serializer;
use Bot::Cobalt::Common ':types';
use Time::HiRes 'sleep';
use Moo;
has file => (
required => 1,
is => 'rw',
isa => (Str | Object),
);
{ no warnings 'once'; *File = *file; }
has perms => (
is => 'rw',
builder => sub { 0644 },
);
{ no warnings 'once'; *Perms = *perms; }
has raw => (
is => 'rw',
isa => Bool,
builder => sub { 0 },
);
{ no warnings 'once'; *Raw = *raw; }
has timeout => (
is => 'rw',
isa => Num,
builder => sub { 5 },
);
{ no warnings 'once'; *Timeout = *timeout; }
has serializer => (
lazy => 1,
is => 'rw',
isa => Object,
builder => sub {
Bot::Cobalt::Serializer->new(Format => 'JSON')
},
);
{ no warnings 'once'; *Serializer = *serializer; }
## _orig is the original tie().
has _orig => (
is => 'rw',
isa => HashRef,
builder => sub { {} },
);
## tied is the re-tied DB hash.
has tied => (
is => 'rw',
isa => HashRef,
builder => sub { {} },
);
{ no warnings 'once'; *Tied = *tied; }
has _lockfh => (
lazy => 1,
is => 'rw',
isa => FileHandle,
predicate => '_has_lockfh',
clearer => '_clear_lockfh',
);
## LOCK_EX or LOCK_SH for current open
has _lockmode => (
lazy => 1,
is => 'rw',
predicate => '_has_lockmode',
clearer => '_clear_lockmode',
);
## DB object.
has DB => (
lazy => 1,
is => 'rw',
isa => Object,
predicate => 'has_DB',
clearer => 'clear_DB',
);
has is_open => (
is => 'rw',
isa => Bool,
default => sub { 0 },
);
sub BUILDARGS {
my ($class, @args) = @_;
return +{ file => $args[0] } if @args == 1;
# Back-compat and I hate myself
my %opt = @args;
my $lower = array( qw/
File
Perms
Raw
Timeout
Serializer
Tied
/ );
for my $key (%opt) {
if ( $lower->has_any(sub { $_ eq $key }) ) {
my $val = delete $opt{$key};
$opt{lc $key} = $val
}
}
\%opt
}
sub DESTROY {
my ($self) = @_;
$self->dbclose if $self->is_open;
}
sub dbopen {
my ($self, %args) = @_;
$args{lc $_} = delete $args{$_} for keys %args;
## per-open timeout was specified:
$self->timeout( $args{timeout} ) if $args{timeout};
if ($self->is_open) {
carp "Attempted dbopen() on already-open DB";
return
}
my ($lflags, $fflags);
if ($args{ro} || $args{readonly}) {
$lflags = LOCK_SH | LOCK_NB ;
$fflags = O_CREAT | O_RDONLY ;
$self->_lockmode(LOCK_SH);
} else {
$lflags = LOCK_EX | LOCK_NB;
$fflags = O_CREAT | O_RDWR ;
$self->_lockmode(LOCK_EX);
}
my $path = $self->file;
## proper DB_File locking:
## open and tie the DB to _orig
## set up object
## call a sync() to create if needed
my $orig_db = tie %{ $self->_orig }, "DB_File", $path,
$fflags, $self->perms, $DB_HASH
or confess "failed db open: $path: $!" ;
$orig_db->sync();
## dup a FH to $db->fd for _lockfh
my $fd = $orig_db->fd;
my $fh = IO::File->new("<&=$fd")
or confess "failed dup in dbopen: $!";
my $timer = 0;
my $timeout = $self->timeout;
## flock _lockfh
until ( flock $fh, $lflags ) {
if ($timer > $timeout) {
warn "failed lock for db $path, timeout (${timeout}s)\n";
undef $orig_db; undef $fh;
untie %{ $self->_orig };
return
}
sleep 0.01;
$timer += 0.01;
}
## reopen DB to Tied
my $db = tie %{ $self->tied }, "DB_File", $path,
$fflags, $self->perms, $DB_HASH
or confess "failed db reopen: $path: $!";
## preserve db obj and lock fh
$self->is_open(1);
$self->_lockfh($fh);
$self->DB($db);
undef $orig_db;
## install filters
## null-terminated to be C-compat
$self->DB->filter_fetch_key(
sub { s/\0$// }
);
$self->DB->filter_store_key(
sub { $_ .= "\0" }
);
## JSONified values
$self->DB->filter_fetch_value(
sub {
s/\0$//;
$_ = $self->serializer->ref_from_json($_)
unless $self->raw;
}
);
$self->DB->filter_store_value(
sub {
$_ = $self->serializer->json_from_ref($_)
unless $self->raw;
$_ .= "\0";
}
);
1
}
sub dbclose {
my ($self) = @_;
unless ($self->is_open) {
carp "attempted dbclose on unopened db";
return
}
if ($self->_lockmode == LOCK_EX) {
$self->DB->sync();
}
$self->clear_DB;
untie %{ $self->tied }
or carp "dbclose: untie tied: $!";
flock( $self->_lockfh, LOCK_UN )
or carp "dbclose: unlock: $!";
untie %{ $self->_orig }
or carp "dbclose: untie _orig: $!";
$self->_clear_lockfh;
$self->_clear_lockmode;
$self->is_open(0);
return 1
}
sub get_tied {
my ($self) = @_;
confess "attempted to get_tied on unopened db"
unless $self->is_open;
$self->tied
}
sub get_db {
my ($self) = @_;
confess "attempted to get_db on unopened db"
unless $self->is_open;
$self->DB
}
sub dbkeys {
my ($self) = @_;
confess "attempted 'dbkeys' on unopened db"
unless $self->is_open;
wantarray ?
(keys %{ $self->tied })
: scalar keys %{ $self->tied }
}
sub get {
my ($self, $key) = @_;
confess "attempted 'get' on unopened db"
unless $self->is_open;
exists $self->Tied->{$key} ? $self->tied->{$key} : ()
}
sub put {
my ($self, $key, $value) = @_;
confess "attempted 'put' on unopened db"
unless $self->is_open;
$self->tied->{$key} = $value
}
sub del {
my ($self, $key) = @_;
confess "attempted 'del' on unopened db"
unless $self->is_open;
return unless exists $self->tied->{$key};
delete $self->tied->{$key};
1
}
sub dbdump {
my ($self, $format) = @_;
confess "attempted dbdump on unopened db"
unless $self->is_open;
$format = 'YAMLXS' unless $format;
## shallow copy to drop tied()
my %copy = %{ $self->tied };
return \%copy if lc($format) eq 'hash';
my $dumper = Bot::Cobalt::Serializer->new( Format => $format );
$dumper->freeze(\%copy)
}
1;
__END__
=pod
=head1 NAME
Bot::Cobalt::DB - Locking Berkeley DBs with serialization
=head1 SYNOPSIS
use Bot::Cobalt::DB;
## ... perhaps in a Cobalt_register ...
my $db_path = $core->var ."/MyDatabase.db";
my $db = Bot::Cobalt::DB->new(
file => $db_path,
);
## Open (and lock):
$db->dbopen;
## Do some work:
$db->put( SomeKey => $some_deep_structure );
for my $key ($db->dbkeys) {
my $this_hash = $db->get($key);
}
## Close and unlock:
$db->dbclose;
=head1 DESCRIPTION
B<Bot::Cobalt::DB> provides a simple object-oriented interface to basic
L<DB_File> (Berkeley DB 1.x) usage.
BerkDB is a fast and simple key/value store. This module uses JSON to
store nested Perl data structures, providing easy database-backed
storage for L<Bot::Cobalt> plugins.
=head2 Constructor
B<new()> is used to create a new Bot::Cobalt::DB object representing your
Berkeley DB:
my $db = Bot::Cobalt::DB->new(
file => $path_to_db,
## Optional arguments:
# Database file mode
perms => $octal_mode,
## Locking timeout in seconds
## Defaults to 5s:
timeout => 10,
## Normally, references are serialized transparently.
## If raw is enabled, no serialization filter is used and you're
## on your own.
raw => 0,
);
=head2 Opening and closing
Database operations should be contained within a dbopen/dbclose:
## open, put, close:
$db->dbopen || croak "dbopen failure";
$db->put($key, $data);
$db->dbclose;
## open for read-only, read, close:
$db->dbopen(ro => 1) || croak "dbopen failure";
my $data = $db->get($key);
$db->dbclose;
Methods will fail if the DB is not open.
If the DB for this object is open when the object is DESTROY'd, Bot::Cobalt::DB
will attempt to close it safely.
=head2 Locking
Proper locking is done -- that means the DB is 're-tied' after a lock is
granted and state cannot change between database open and lock time.
The attempt to gain a lock will time out after five seconds (and
L</dbopen> will return boolean false).
The lock is cleared on L</dbclose>.
If the Bot::Cobalt::DB object is destroyed, it will attempt to dbclose
for you, but it is good practice to keep track of your open/close
calls and attempt to close as quickly as possible.
=head2 Methods
=head3 dbopen
B<dbopen> opens and locks the database. If 'ro => 1' is specified,
this is a LOCK_SH shared (read) lock; otherwise it is a LOCK_EX
exclusive (write) lock.
Try to call a B<dbclose> as quickly as possible to reduce locking
contention.
dbopen() will return false (and possibly warn) if the database could
not be opened (probably due to lock timeout).
=head3 is_open
Returns a boolean value representing whether or not the DB is currently
open and locked.
=head3 dbclose
B<dbclose> closes and unlocks the database.
=head3 put
The B<put> method adds an entry to the database:
$db->put($key, $value);
The value can be any data structure serializable by L<JSON::MaybeXS>.
Note that keys should be properly encoded:
my $key = "\x{263A}";
utf8::encode($key);
$db->put($key, $data);
=head3 get
The B<get> method retrieves a (deserialized) key.
$db->put($key, { Some => 'hash' } );
## . . . later on . . .
my $ref = $db->get($key);
=head3 del
The B<del> method removes a key from the database.
$db->del($key);
=head3 dbkeys
B<dbkeys> will return a list of keys in list context, or the number
of keys in the database in scalar context.
=head3 dbdump
You can serialize/export the entirety of the DB via B<dbdump>.
## Export to a HASH
my $dbcopy = $db->dbdump('HASH');
## YAML::Syck
my $yamlified = $db->dbdump('YAML');
## YAML::XS
my $yamlified = $db->dbdump('YAMLXS');
## JSON::MaybeXS
my $jsonified = $db->dbdump('JSON');
See L<Bot::Cobalt::Serializer> for more on C<freeze()> and valid formats.
A tool called B<cobalt2-dbdump> is available as a
simple frontend to this functionality. See C<cobalt2-dbdump --help>
=head1 FORMAT
B<Bot::Cobalt::DB> databases are Berkeley DB 1.x, with NULL-terminated records
and values stored as JSON. They're intended to be easily portable to
other non-Perl applications.
=head1 AUTHOR
Jon Portnoy <avenj@cobaltirc.org>
=cut