view release on metacpan or  search on metacpan

DB_File.pm  view on Meta::CPAN

        R_NEXT
        R_NOKEY
        R_NOOVERWRITE
        R_PREV
        R_RECNOSYNC
        R_SETCURSOR
        R_SNAPSHOT
        __R_UNUSED

);

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


eval {
    # Make all Fcntl O_XXX constants available for importing
    require Fcntl;
    my @O = grep /^O_/, @Fcntl::EXPORT;
    Fcntl->import(@O);  # first we import what we want to export
    push(@EXPORT, @O);
};

if ($use_XSLoader)
  { XSLoader::load("DB_File", $VERSION)}
else
  { DB_File->bootstrap( $VERSION ) }

sub tie_hash_or_array
{
    my (@arg) = @_ ;
    my $tieHASH = ( (caller(1))[3] =~ /TIEHASH/ ) ;

    use File::Spec;
    $arg[1] = File::Spec->rel2abs($arg[1])
        if defined $arg[1] ;

    $arg[4] = tied %{ $arg[4] }
        if @arg >= 5 && ref $arg[4] && $arg[4] =~ /=HASH/ && tied %{ $arg[4] } ;

    $arg[2] = O_CREAT()|O_RDWR() if @arg >=3 && ! defined $arg[2];
    $arg[3] = 0666               if @arg >=4 && ! defined $arg[3];

    # make recno in Berkeley DB version 2 (or better) work like
    # recno in version 1.
    if ($db_version >= 4 and ! $tieHASH) {
        $arg[2] |= O_CREAT();
    }

    if ($db_version > 1 and defined $arg[4] and $arg[4] =~ /RECNO/ and
        $arg[1] and ! -e $arg[1]) {
        open(FH, ">$arg[1]") or return undef ;
        close FH ;
        chmod $arg[3] ? $arg[3] : 0666 , $arg[1] ;
    }

    DoTie_($tieHASH, @arg) ;
}

sub TIEHASH
{
    tie_hash_or_array(@_) ;
}

sub TIEARRAY
{
    tie_hash_or_array(@_) ;
}

sub CLEAR
{
    my $self = shift;
    my $key = 0 ;
    my $value = "" ;
    my $status = $self->seq($key, $value, R_FIRST());
    my @keys;

    while ($status == 0) {
        push @keys, $key;
        $status = $self->seq($key, $value, R_NEXT());
    }
    foreach $key (reverse @keys) {
        my $s = $self->del($key);
    }
}

sub EXTEND { }

sub STORESIZE
{
    my $self = shift;
    my $length = shift ;
    my $current_length = $self->length() ;

    if ($length < $current_length) {
        my $key ;
        for ($key = $current_length - 1 ; $key >= $length ; -- $key)
          { $self->del($key) }
    }
    elsif ($length > $current_length) {
        $self->put($length-1, "") ;
    }
}


sub SPLICE
{
    my $self = shift;
    my $offset = shift;
    if (not defined $offset) {
        warnings::warnif('uninitialized', 'Use of uninitialized value in splice');
        $offset = 0;
    }