File Coverage

blib/lib/LMDB_File.pm

Criterion	Covered	Total	%
statement	244	292	83.5
branch	82	156	52.5
condition	51	92	55.4
subroutine	53	63	84.1
pod	15	17	88.2
total	445	620	71.7

package LMDB_File;

use 5.010000;
use strict;
use warnings;
use Carp;

require Exporter;
use AutoLoader;

our $VERSION = '0.10';
our $DEBUG = 0;

our @ISA = qw(Exporter);
our @CARP_NOT = qw(LMDB::Env LMDB::Txn LMDB::Cursor LMDB_File);

our @EXPORT = qw();
our %EXPORT_TAGS = (
    envflags => [qw(MDB_FIXEDMAP MDB_NOSUBDIR MDB_NOSYNC MDB_RDONLY MDB_NOMETASYNC
	MDB_NOMEMINIT MDB_WRITEMAP MDB_MAPASYNC MDB_NOTLS MDB_NOLOCK MDB_NORDAHEAD)],
    dbflags => [qw(MDB_REVERSEKEY MDB_DUPSORT MDB_INTEGERKEY MDB_DUPFIXED
	MDB_INTEGERDUP MDB_REVERSEDUP MDB_CREATE)],
    writeflags => [qw(MDB_NOOVERWRITE MDB_NODUPDATA MDB_CURRENT MDB_RESERVE
	MDB_APPEND MDB_APPENDDUP MDB_MULTIPLE)],
    cursor_op => [qw(MDB_FIRST MDB_FIRST_DUP MDB_GET_BOTH MDB_GET_BOTH_RANGE
	MDB_GET_CURRENT MDB_GET_MULTIPLE MDB_NEXT MDB_NEXT_DUP MDB_NEXT_MULTIPLE
	MDB_NEXT_NODUP MDB_PREV MDB_PREV_DUP MDB_PREV_NODUP MDB_LAST MDB_LAST_DUP
	MDB_SET MDB_SET_KEY MDB_SET_RANGE)],
    copyflags => [qw(MDB_CP_COMPACT)],
    error => [qw(MDB_SUCCESS MDB_KEYEXIST MDB_NOTFOUND MDB_PAGE_NOTFOUND MDB_CORRUPTED
	MDB_PANIC MDB_VERSION_MISMATCH MDB_INVALID MDB_MAP_FULL MDB_DBS_FULL
	MDB_READERS_FULL MDB_TLS_FULL MDB_TXN_FULL MDB_CURSOR_FULL MDB_PAGE_FULL
	MDB_MAP_RESIZED MDB_INCOMPATIBLE MDB_BAD_RSLOT MDB_BAD_TXN MDB_BAD_VALSIZE
	MDB_BAD_DBI MDB_LAST_ERRCODE)],
    version => [qw(MDB_VERSION_FULL MDB_VERSION_MAJOR MDB_VERSION_MINOR
	MDB_VERSION_PATCH MDB_VERSION_STRING MDB_VERSION_DATE)],
);
$EXPORT_TAGS{flags} = [
    @{$EXPORT_TAGS{envflags}}, @{$EXPORT_TAGS{dbflags}},
    @{$EXPORT_TAGS{writeflags}}, @{$EXPORT_TAGS{copyflags}}
];
{
    my %seen;
    push @{$EXPORT_TAGS{all}},
	grep {!$seen{$_}++} @{$EXPORT_TAGS{$_}} foreach keys %EXPORT_TAGS;
}
our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

sub AUTOLOAD {
    my $constname;
    our $AUTOLOAD;
    ($constname = $AUTOLOAD) =~ s/.*:://;
    croak "&LMDB_File::constant not defined" if $constname eq 'constant';
    my ($error, $val) = constant($constname);
    if ($error) { croak $error; }
    {
	no strict 'refs';
	*$AUTOLOAD = sub { $val };
    }
    goto &$AUTOLOAD;
}

require XSLoader;
XSLoader::load('LMDB_File', $VERSION);

my $dbflmask = do {
    no strict 'refs';
    my $f = 0;
    $f |= &{"LMDB_File::$_"}() for @{$EXPORT_TAGS{dbflags}};
    $f;
};

package LMDB::Env;
use Scalar::Util ();
use Fcntl;

our %Envs;
sub new {
    my ($proto, $path, $eflags) = @_;
    create(my $self);
    return unless $self;
    $eflags = { flags => ($eflags || 0) } unless ref $eflags;
    $eflags->{mapsize} and $self->set_mapsize($eflags->{mapsize})
	and return;
    $eflags->{maxdbs} and $self->set_maxdbs($eflags->{maxdbs})
	and return;
    $eflags->{maxreaders} and $self->set_maxreaders($eflags->{maxreaders})
	and return;
    if($^O =~ /openbsd/) {
	# OpenBSD lacks an unified buffer cache (UBC) so LMDB only works
	# with MDB_WRITEMAP set when not in read-only mode
	$eflags->{flags} |= LMDB_File::MDB_WRITEMAP()
	    unless $eflags->{flags} & LMDB_File::MDB_RDONLY();
    }
    $self->open($path, $eflags->{flags}, $eflags->{mode} || 0600)
	and return;
    warn "Created LMDB::Env $$self\n" if $DEBUG;
    return $self;
}

sub Clean {
    my $self = shift;
    my $txl = $Envs{ $$self }[0] or return;
    if(@$txl) {
	Carp::carp("LMDB: Aborting $#$txl transactions in $$self.");
	$txl->[$#$txl]->abort;
    }
    $Envs{ $$self }[0] = [];
}

sub DESTROY {
    my $self = shift;
    my $txl = $Envs{ $$self } && $Envs{ $$self }[0];
    if($txl and @$txl and my $topTxn = $txl->[$#$txl]) {
	# As every Txn references its Env this is only possible at global destruction
        Carp::carp("LMDB: OOPS! Destroying an active environment!");
        warn("LMDB: Aborting $#$txl transactions in $$self.") if $DEBUG;
        $topTxn->abort;
    }
    $self->close;
    warn "Closed LMDB::Env $$self (remains @{[scalar keys %Envs]})\n"
	if $DEBUG;
}

sub BeginTxn {
    my $self = shift;
    $self->get_flags(my $eflags);
    my $tflags = shift || ($eflags & LMDB_File::MDB_RDONLY());
    my $txl = $Envs{ $$self }[0];
    warn "BeginTxn $$self($$), deep: ", scalar(@$txl), "\n" if $DEBUG;
    return $txl->[0]->SubTxn($tflags) if @$txl;
    LMDB::Txn->new($self, $tflags);
}

sub CLONE {
    # After a thread is created all Txns of parent thread are forgot
    $_->[0] = [] for values %Envs;
    _clone();
    1;
}

package LMDB::Txn;

our %Txns;
my %Cursors;

sub new {
    my ($parent, $env, $tflags) = @_;
    my $txl = $Envs{ $$env }[0];
    Carp::croak("Transaction active, should be subtransaction")
	if !ref($parent) && @$txl;
    _begin($env, ref($parent) && $parent, $tflags, my $self);
    return unless $self;
    $Txns{$$self} = {
	Active => 1,
	Env => $env, # A transaction references the environment
	RO  => $tflags & LMDB_File::MDB_RDONLY(),
    };
    unshift @$txl, $self;
    Scalar::Util::weaken($txl->[0]);
    warn "Created LMDB::Txn $$self in $$env\n" if $DEBUG;
    return $self;
}

sub SubTxn {
    my $self = shift;
    if($^O =~ /openbsd/) {
	# Needs MDB_WRITEMAP so
	Carp::croak("Subtransactions are unsupported in this OS");
    }
    my $tflags = shift || 0;
    return $self->new($self->env, $tflags);
}

sub DESTROY {
    my $self = shift;
    my $td = $Txns{ $$self } or return;
    if($td->{Active} && !$td->{RO} && $td->{AC}) {
	warn "LMDB: Destroying an active transaction, commiting $$self...\n"
	    if $DEBUG;
	$self->commit;
    } else {
	warn "LMDB: Destroying an active transaction, aborting $$self...\n"
	    if $DEBUG;
	$self->abort;
    }
}

sub _prune {
    my $self = shift;
    my $eid = shift;
    if(my $txl = $Envs{ $eid } && $Envs{ $eid }[0]) {
	while(my $rel = shift @$txl) {
	    my $td =  delete $Txns{ $$rel };
	    delete $Cursors{$_} for keys %{ $td->{Cursors} };
	    last if $$rel == $$self;
	}
	warn "LMDB::Txn: Txns list deep: @{[scalar @$txl]}\n" if $DEBUG > 2;
    }
    warn "LMDB::Txn: $$self($$) finalized in $eid\n" if $DEBUG > 1;
    $$self = 0;
}

sub abort {
    my $self = shift;
    unless($Txns{ $$self }) {
	Carp::carp("Terminated transaction");
	return;
    }
    my $eid = $self->_env;
    $self->_abort;
    warn "LMDB::Txn $$self aborted\n" if $DEBUG;
    $self->_prune($eid);
}

sub commit {
    my $self = shift;
    my $td = $Txns{ $$self } or Carp::croak("Terminated transaction");
    Carp::croak("Not an active transaction") unless $td->{Active};
    my $eid = $self->_env;
    $self->_commit;
    warn "LMDB::Txn $$self commited\n" if $DEBUG;
    $self->_prune($eid);
}

sub Flush {
    my $self = shift;
    my $td = $Txns{ $$self } or Carp::croak("Terminated transaction");
    Carp::croak("Not an active transaction") unless $td->{Active};
    $self->_commit;
    # This depends on malloc order, beware!
    _begin($td->{Env}, undef, $td->{RO}, my $ntxn);
    Carp::croak("Can't recreate Txn") unless $$ntxn == $$self;
    $$ntxn = 0;
}

sub reset {
    my $self = shift;
    my $td = $Txns{ $$self } or Carp::croak("Terminated transaction");
    Carp::croak("Not a read-only transaction") unless $td->{RO};
    $self->_reset if $td->{Active};
    $td->{Active} = 0;
}

sub renew {
    my $self = shift;
    my $td = $Txns{ $$self } or Carp::croak("Terminated transaction");
    $self->_reset if $td->{Active};
    $self->_renew;
    $td->{Active} = 1;
}

sub OpenDB {
    my ($self, $name, $flags) = @_;
    my $options = ref($name) eq 'HASH' ? $name : { dbname => $name, flags => $flags };
    LMDB_File->open($self, $options->{dbname}, $options->{flags});
}

sub env {
    my $self = shift;
    $Txns{$$self} && $Txns{$$self}{Env};
}

sub AutoCommit {
    my $self = shift;
    my $td = $Txns{ $$self } or Carp::croak("Terminated transaction");
    my $prev = $td->{AC};
    $td->{AC} = shift if(@_);
    $prev;
}

# Fast low-level dbi API
sub open {
    my($txn, $name, $flags) = @_;
     $flags ||= 0;
    Carp::croak("Not an alive transaction") unless $Txns{ $$txn };
    Carp::croak("Not the current child transaction")
	unless(${$Envs{ $txn->_env }[0][0]} == $$txn);
    _dbi_open($txn, $name, $flags & $dbflmask, my $dbi);
    warn "Opened dbi $dbi\n" if $dbi && $DEBUG;
    return $dbi;
}
*get = \&LMDB_File::_get;
*put = \&LMDB_File::_put;
*del = \&LMDB_File::_del;

sub CLONE_SKIP {
    # All LMDB Transactions are usable only in the thread that create it
    1;
}

package LMDB::Cursor;

sub get {
    LMDB_File::_chkalive($Cursors{${$_[0]}});
    goto &_get;
}

sub put {
    LMDB_File::_chkalive($Cursors{${$_[0]}});
    goto &_put;
}

sub del {
    LMDB_File::_chkalive($Cursors{${$_[0]}});
    goto &_del;
}

sub DESTROY {
    my $self = shift;
    return unless $Cursors{$$self};
    my $txnId = $self->txn;
    $self->close;
    delete $Txns{$txnId}{Cursors}{$$self};
    delete $Cursors{$$self};
}

package LMDB_File;
sub CLONE_SKIP { 1; }

our $die_on_err = 1;
our $last_err = 0;

sub new {
    my($proto, $txn, $dbi) = @_;
    Carp::croak("Need a Txn") unless $txn->isa('LMDB::Txn');
    bless [ $txn, $dbi ], ref($proto) || $proto;
}

sub open {
    my $proto = shift;
    my $class = ref $proto;
    my $txn = $class ? $proto->[0] : shift;
    Carp::croak("Need a Txn") unless $txn->isa('LMDB::Txn');
    my $dbi = $txn->open(@_) or return;
    bless [ $txn, $dbi ], $class || $proto;
}

sub DESTROY {
    my $self = shift;
}

sub _chkalive {
    my $self = shift;
    my $txn = $self->[0];
    Carp::croak("Not an active transaction")
	unless($txn && ($Txns{ $$txn } || undef $self->[0]) && $Txns{ $$txn }{Active} );
    # A parent transaction and its cursors may not issue any other operations than
    # mdb_txn_commit and mdb_txn_abort while it has active child transactions.
    Carp::croak("Not the current child transaction")
	unless(${$Envs{ $txn->_env }[0][0]} == $$txn);
    $txn, $self->[1];
}

sub Alive {
    my $self = shift;
    my $txn = $self->[0];
    $txn && (($Txns{ $$txn } && $self->[1]) || undef $self->[0]);
}

sub flags {
    my $self = shift;
    _dbi_flags(_chkalive($self), my $flags);
    $flags;
}

sub put {
    my $self = shift;
    warn "put: '$_[0]' => '$_[1]'\n" if $DEBUG > 2;
    _put(_chkalive($self), @_);
    $_[1];
}

sub get {
    warn "get: '$_[1]'\n" if $DEBUG > 2;
    my($txn, $dbi) = _chkalive($_[0]);
    return _get($txn, $dbi, $_[1], $_[2]) if @_ > 2;
    my($res, $data);
    {
	local $die_on_err = 0;
	$res = _get($txn, $dbi, $_[1], $data);
    }
    croak($@) if $res && $die_on_err && $res != MDB_NOTFOUND() or undef $@;
    $data;
}

sub Rget {
    warn "get: '$_[1]'\n" if $DEBUG > 2;
    local $die_on_err = 0;
    _get(_chkalive($_[0]), $_[1], my $data);
    return \$data;
}


sub del {
    _del(_chkalive($_[0]), $_[1], $_[2]);
}

sub stat {
    _stat(_chkalive($_[0]));
}

sub set_dupsort {
    my $self = shift;
    my $txn = $self->[0];
    $Envs{ $txn->_env }[1][ $self->[1] ] = shift;
}

sub set_compare {
    my $self = shift;
    my $txn = $self->[0];
    $Envs{ $txn->_env }[2][ $self->[1] ] = shift;
}

sub Cursor {
    my $DB = shift;
    my ($txn, $dbi) = _chkalive($DB);
    LMDB::Cursor::open($txn, $dbi, my $cursor);
    return unless $cursor;
    $Txns{$$txn}{Cursors}{$$cursor} = 1;
    $Cursors{$$cursor} = $DB;
    warn "Cursor opened for #$dbi\n" if $DEBUG;
    $cursor;
}

sub Txn : lvalue { $_[0][0]; }

sub dbi : lvalue { $_[0][1]; }

sub drop {
    _drop(_chkalive($_[0]), $_[1] || 0);
}

sub TIEHASH {
    my $proto = shift;
    return $proto if ref($proto) && _chkalive($proto); # Auto
    my $mux = shift;
    my $options = shift;
    $options = { flags => $options } unless ref $options; # DBM Compat
    my $txn;
    if(ref $mux eq 'LMDB::Txn') {
	$txn = $mux;
    } elsif(ref $mux eq 'LMDB::Env') {
	$txn = $mux->BeginTxn;
	$txn->AutoCommit(1);
    } else { # mux is dir
	$options->{mode} = shift if @_; # DBM Compat
	$txn = LMDB::Env->new($mux, $options)->BeginTxn;
	$txn->AutoCommit(1);
    }
    $txn->OpenDB($options);
}

sub FETCH {
    my($self, $key) = @_;
    my ($data, $res);
    {
	local $die_on_err = 0;
	$res = _get(_chkalive($self), $key, $data);
    }
    croak($@) if $res && $die_on_err && $res != MDB_NOTFOUND() or undef $@;
    $data;
}

*STORE = \&put;
*CLEAR = \&drop;

sub UNTIE {
    my $self = shift;
    my $txn = $self->[0];
    return unless($txn && ($Txns{ $$txn } || undef($self->[0])));
    delete $self->[2]; # Free cursor
}

sub SCALAR {
    return $_[0]->stat->{entries};
}

sub EXISTS {
    my($self, $key) = @_;
    local $die_on_err = 0;
    return !_get(_chkalive($self), $key, my $dummy);
}

sub DELETE {
    my($self, $key) = @_;
    my @self = _chkalive($self);
    my $data;
    local $die_on_err = 0;
    if(_get(@self, $key, $data) != MDB_NOTFOUND()) {
	_del(@self, $key, undef);
    }
    return $data;
}

sub FIRSTKEY {
    my $self = shift;
    $self->[2] = $self->Cursor;
    $self->NEXTKEY;
}

# I hop some day tie hashed are optimized
sub NEXTKEY {
    my($self, $key) = @_;
    my $op = defined($key) ? MDB_NEXT() : MDB_FIRST() ;
    local $die_on_err = 0;
    my $res = $self->[2]->get($key, my $data, $op);
    if($res == MDB_NOTFOUND()) {
	return;
    }
    return wantarray ? ($key, $data) : $key;
}

sub _mydbflags {
    my($envid, $dbi, $bit) = @_;
    my $cm = \vec($Envs{ $envid }[3], $dbi, LMDB_OFLAGN());
    my $om = $$cm;
    if(@_ > 3) {
	$$cm = $_[3] ? ($$cm | $bit) : ($$cm & ~$bit);
	_resetcurdbi();
    }
    return $om & $bit;
}

sub ReadMode {
    my $self = shift;
    my($txn, $dbi) = _chkalive($self);
    _mydbflags($txn->_env, $dbi, 1, @_);
}

sub UTF8 {
    my $self = shift;
    my($txn, $dbi) = _chkalive($self);
    _mydbflags($txn->_env, $dbi, 2, @_);
}

1;
__END__