File Coverage

blib/lib/CHI/Driver/BerkeleyDB.pm

Criterion	Covered	Total	%
statement	4	6	66.6
branch			n/a
condition			n/a
subroutine	2	2	100.0
pod			n/a
total	6	8	75.0

package CHI::Driver::BerkeleyDB;
use 5.006;
use BerkeleyDB;
use CHI::Util qw(read_dir);
use File::Path qw(mkpath);
use Moose;
use strict;
use warnings;

extends 'CHI::Driver';

our $VERSION = '0.03';

has 'db'       => ( is => 'ro', lazy_build => 1 );
has 'db_class' => ( is => 'ro', default    => 'BerkeleyDB::Hash' );
has 'dir_create_mode' => ( is => 'ro', isa => 'Int', default => oct(775) );
has 'env' => ( is => 'ro', lazy_build => 1 );
has 'filename' => ( is => 'ro', init_arg => undef, lazy_build => 1 );
has 'root_dir' => ( is => 'ro' );

__PACKAGE__->meta->make_immutable();

sub _build_filename {
    my $self = shift;
    return $self->escape_for_filename( $self->namespace ) . ".db";
}

sub _build_env {
    my $self = shift;

    my $root_dir = $self->root_dir;
    die "must specify one of env or root_dir" if !defined($root_dir);
    mkpath( $root_dir, 0, $self->dir_create_mode )
      if !-d $root_dir;
    my $env = BerkeleyDB::Env->new(
        '-Home'   => $self->root_dir,
        '-Config' => {},
        '-Flags'  => DB_CREATE | DB_INIT_CDB | DB_INIT_MPOOL
      )
      or die sprintf( "cannot open Berkeley DB environment in '%s': %s",
        $root_dir, $BerkeleyDB::Error );
    return $env;
}

sub _build_db {
    my $self = shift;

    my $filename = $self->filename;
    my $db       = $self->db_class->new(
        '-Filename' => $filename,
        '-Flags'    => DB_CREATE,
        '-Env'      => $self->env
      )
      or die
      sprintf( "cannot open Berkeley DB file '%s' in environment '%s': %s",
        $filename, $self->root_dir, $BerkeleyDB::Error );
    return $db;
}

sub fetch {
    my ( $self, $key ) = @_;

    my $data;
    return ( $self->db->db_get( $key, $data ) == 0 ) ? $data : undef;
}

sub store {
    my ( $self, $key, $data ) = @_;

    $self->db->db_put( $key, $data ) == 0
      or die $BerkeleyDB::Error;
}

sub remove {
    my ( $self, $key ) = @_;

    $self->db->db_del($key) == 0
      or die $BerkeleyDB::Error;
}

sub clear {
    my ($self) = @_;

    my $count = 0;
    $self->db->truncate($count) == 0
      or die $BerkeleyDB::Error;
}

sub get_keys {
    my ($self) = @_;

    my @keys;
    my $cursor = $self->db->db_cursor();
    my ( $key, $value ) = ( "", "" );
    while ( $cursor->c_get( $key, $value, BerkeleyDB::DB_NEXT() ) == 0 ) {
        push( @keys, $key );
    }
    return @keys;
}

sub get_namespaces {
    my ($self) = @_;

    my @contents = read_dir( $self->root_dir );
    my @namespaces =
      map { $self->unescape_for_filename( substr( $_, 0, -3 ) ) }
      grep { /\.db$/ } @contents;
    return @namespaces;
}

1;

__END__