File Coverage

blib/lib/Bot/Cobalt/DB.pm

Criterion	Covered	Total	%
statement	12	14	85.7
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	17	19	89.4

package Bot::Cobalt::DB;
$Bot::Cobalt::DB::VERSION = '0.021001';
## 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__