File Coverage

blib/lib/Tie/MAB2/Dualdb.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 Tie::MAB2::Dualdb;

use strict;

BEGIN {
  use Tie::Array;
  our @ISA = qw(Tie::Array);
}

use BerkeleyDB qw( DB_RDONLY DB_CREATE DB_FAST_STAT DB_INIT_MPOOL DB_INIT_CDB);

use Tie::MAB2::Dualdb::Recno;
use Tie::MAB2::Dualdb::Id;
use MAB2::Record::Base;
use File::Basename;

sub TIEARRAY {
  my($class,%args) = @_;
  my $self = {};
  $self->{ARGS} = \%args;

  # directory?
  die unless $args{filename};
  my $dir      = File::Basename::dirname($args{filename});
  my $basename = File::Basename::basename($args{filename});

  # environment?
  my $flags = $args{flags};
  my $env = BerkeleyDB::Env
      ->new(
            Home => $dir,
            Flags => $flags|DB_INIT_MPOOL,
           )
          or die "Could not create environment: $BerkeleyDB::Error; home[$dir]flags[$args{flags}]";
  $self->{ENV} = $env;

  my @recs;
  tie(@recs,
      "Tie::MAB2::Dualdb::Recno",
      filename => "$basename",
      flags => $flags,
      env => $env,
     ) or die "Could not tie \@recs: $BerkeleyDB::Error";
  $self->{RECS} = \@recs;
  my %recnos;
  tie(%recnos,
      "Tie::MAB2::Dualdb::Id",
      filename => "$basename",
      flags => $flags,
      env => $env,
     ) or die "Could not tie %recnos: $BerkeleyDB::Error";
  $self->{IDS} = \%recnos;

  bless $self, ref $class || $class;
}

sub env {
  shift->{ENV};
}

sub UNTIE {
  my $self = shift;
  untie %{$self->{IDS}};
  untie @{$self->{RECS}};
  delete $self->{ENV};
}

sub FETCH {
  my($self, $key) = @_;
  my $obj = $self->{RECS}[$key];
  $obj;
}

sub FETCHSIZE {
  my($self) = @_;
  scalar @{$self->{RECS}}
}

sub EXISTS {
  my($self,$key) = @_;
  exists $self->{RECS}[$key];
}

sub STORE {
  my($self,$key,$val) = @_;
  if (my $oldrec = $self->{RECS}[$key]) {
    my $oldid = $oldrec->id;
    delete $self->{IDS}{$oldid};
  }
  if (! defined $val or ! length $val) {
    $self->{RECS}[$key] = "";
    return;
  }
  my $blrec = MAB2::Record::Base->new($val, $key);
  my $id = $blrec->id;
  if (defined(my $oldidx = $self->{IDS}{$id})) {
    if ($oldidx != $key) {
      require Carp;
      Carp::confess("Duplicate record identified: trying to store id[$id] under key[$key] but found it as oldidx[$oldidx]");
    }
  }
  $self->{RECS}[$key] = $val;
  $self->{IDS}{$id} = $key;
}

# sub CLEAR {
#   my($self) = @_;
#   warn "clearing the inner array";
#   @{$self->{RECS}} = ();
#   warn "cleared the inner array";
#   warn "clearing the inner hash";
#   %{$self->{IDS}}  = ();
#   warn "cleared the inner hash";
# }

for my $method (qw(STORESIZE CLEAR POP SHIFT UNSHIFT SPLICE)) {
  no strict "refs";
  *$method = sub {
    require Carp;
    Carp::confess("$method not supported on ".ref shift);
    return;
  };
}

1;

__END__