view release on metacpan or  search on metacpan

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

    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: $!";