view release on metacpan or  search on metacpan

lib/Bot/Cobalt/DB.pm  view on Meta::CPAN

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