File Coverage

blib/lib/BeePack.pm

Criterion	Covered	Total	%
statement	8	10	80.0
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	12	14	85.7

package BeePack;
BEGIN {
  $BeePack::AUTHORITY = 'cpan:GETTY';
}
# ABSTRACT: Primitive MsgPack based key value storage
$BeePack::VERSION = '0.101';
use Moo;
use bytes;
use CDB::TinyCDB;
use Data::MessagePack;
use Carp qw( croak );

sub true { Data::MessagePack::true() }
sub false { Data::MessagePack::false() }

# currently workaround to be reset
has cdb => (
  is => 'rw',
  lazy => 1,
  builder => 1,
  init_arg => undef,
  handles => [qw(
    keys
  )],
);

sub _build_cdb {
  my ( $self ) = @_;
  return -f $self->filename
    ? CDB::TinyCDB->open($self->filename, $self->has_tempfile ? (
        for_update => $self->tempfile
      ) : ())
    : $self->readonly
      ? croak("Can't open non-existing readonly database ".$self->filename)
      : CDB::TinyCDB->create($self->filename,$self->tempfile);
}

has filename => (
  is => 'ro',
  required => 1,
);

has tempfile => (
  is => 'ro',
  predicate => 1,
);

has nil_exists => (
  is => 'lazy',
);

sub _build_nil_exists { 1 }

has readonly => (
  is => 'lazy',
);

sub _build_readonly {
  my ( $self ) = @_;
  return $self->has_tempfile ? 0 : 1;
}

has data_messagepack => (
  is => 'lazy',
  init_arg => undef,
);

sub _build_data_messagepack {
  Data::MessagePack->new->canonical->utf8
}

sub BUILD {
  my ( $self ) = @_;
  croak("Read/Write opening requires tempfile") if !$self->readonly && !$self->has_tempfile;
  $self->cdb;
  $self->data_messagepack;
}

sub open {
  my ( $class, $filename, $tempfile, %attr ) = @_;
  return $class->new(
    filename => $filename,
    defined $tempfile ? ( tempfile => $tempfile ) : (),
    %attr,
  );
}

sub set {
  my ( $self, $key, $value ) = @_;
  croak("Trying to set on readonly BeePack") if $self->readonly;
  $self->cdb->put_replace($key,$self->data_messagepack->pack($value));
}

sub set_type {
  my ( $self, $key, $type, $value ) = @_;
  croak("Trying to set on readonly BeePack") if $self->readonly;
  my $t = defined $type ? substr($type,0,1) : '';
  if ($t eq 'i') {
    $self->set_integer($key,$value);
  } elsif ($t eq 'b') {
    $self->set_bool($key,$value);
  } elsif ($t eq 's') {
    $self->set_string($key,$value);
  } elsif ($t eq 'n') {
    $self->set_nil($key,$value);
  } elsif ($t eq 'a') {
    my @array = @{$value};
    $self->set($key,\@array);
  } elsif ($t eq 'h') {
    my %hash = %{$value};
    $self->set($key,\%hash);
  } elsif ($t eq '') {
    $self->set($key,$value);
  }
}

sub set_integer {
  my ( $self, $key, $value ) = @_;
  $self->set($key, 0 + $value);
}

sub set_bool {
  my ( $self, $key, $value ) = @_;
  $self->set($key, $value
    ? Data::MessagePack::true()
    : Data::MessagePack::false()
  );
}

sub set_string {
  my ( $self, $key, $value ) = @_;
  $self->set($key, "$value");
}

sub set_nil {
  my ( $self, $key ) = @_;
  $self->set($key, undef);
}

sub exists {
  my ( $self, $key ) = @_;
  return 0 unless $self->cdb->exists($key);
  my $msgpack = $self->cdb->get($key);
  my $value = $self->data_messagepack->unpack($msgpack);
  return defined $value ? 1 : 0;
}

sub get {
  my ( $self, $key ) = @_;
  return undef unless $self->exists($key);
  return $self->data_messagepack->unpack(scalar $self->cdb->get($key));
}

sub get_raw {
  my ( $self, $key ) = @_;
  return scalar $self->cdb->get($key);
}

sub save {
  my ( $self ) = @_;
  croak("Trying to save readonly CDB ".$self->filename) if $self->readonly;
  $self->cdb->finish( save_changes => 1, reopen => 0 );
  # Bug in CDB::TinyCDB? reopen => 1 is not reopening
  $self->cdb(undef);
  $self->cdb($self->_build_cdb);
  return 1;
}

1;

__END__