view release on metacpan or  search on metacpan

lib/AC/Yenta/Store/BDBI.pm  view on Meta::CPAN

    }
    return $v;
}

sub put {
    my $me  = shift;
    my $map = shift;
    my $sub = shift;
    my $key = shift;
    my $val = shift;

    debug("put $map/$sub/$key");

    $me->_start();
    my $r = $me->{db}->db_put( _key($map,$sub,$key), $val);
    $me->_finish();

    return !$r;
}

sub del {
    my $me  = shift;
    my $map = shift;
    my $sub = shift;
    my $key = shift;

    $me->_start();
    $me->{db}->db_del( _key($map,$sub,$key));
    $me->_finish();
}

sub sync {
    my $me  = shift;

    $me->{db}->db_sync();
}

sub range {
    my $me  = shift;
    my $map = shift;
    my $sub = shift;
    my $key = shift;
    my $end = shift;	# undef => to end of map

    my ($k, $v, @k);
    $me->_start();
    my $cursor = $me->{db}->db_cursor();
    $k = _key($map,$sub,$key);
    my $e = _key($map,$sub,$end);
    $cursor->c_get($k, $v, DB_SET_RANGE);

    my $MAX = 100;
    my $max = $MAX;

    while( !$end || ($k lt $e) ){
        debug("range $k");
        last unless $k =~ m|$map/$sub/|;
        $k =~ s|$map/$sub/||;
        push @k, { k => $k, v => $v };
        my $r = $cursor->c_get($k, $v, DB_NEXT);
        last if $r;	# error

        # cursor locks the db
        # close+recreate so other processes can proceed
        unless( $max -- ){
            $cursor->c_close();
            $me->_finish();
            sleep 0;
            $me->_start();
            $cursor = $me->{db}->db_cursor();
            $cursor->c_get($k, $v, DB_SET);
            $max = $MAX;
        }
    }
    $cursor->c_close();
    $me->_finish();

    return @k;
}

################################################################

sub _sig {
    print STDERR "bdbi signal @_\n", AC::Error::stack_trace(), "\n";
    exit(-1);
}

sub _start {
    my $me = shift;

    $me->{alarmold} = alarm($TIMEOUT);
    return unless $me->{hasenv};

    # as long as perl handles the signals, everything gets cleaned up
    # well enough for the locks to be removed
    for my $sig (qw(INT QUIT KILL TERM ALRM)){
        $SIG{$sig} ||= \&_sig;
    }
}

sub _finish {
    my $me = shift;

    alarm($me->{alarmold} || 0);
    $me->{alarmold} = 0;
}


sub _key {
    my $map = shift;
    my $sub = shift;
    my $key = shift;

    return "$map/$sub/$key";
}

1;