http://paperlined.org/src/pl/jollies/backend/NeverTMPbackend_dbm.pm

package NeverTMPbackend_dbm;

    use strict;
    use warnings;

    use BerkeleyDB;
    use Storable;


    use Exporter;
    our @EXPORT = qw( $permdb $transdb );





our $permdb;        # permanent.db
our $transdb;       # transient.db

our %permdb;
our %transdb;


sub open_dbs {
    my $directory = shift or die "Please specify database location.";

    $permdb = tie %permdb, 'BerkeleyDB::Btree',
            -Filename => "$directory/permanent.db",
            -Flags    => DB_CREATE
                or die "Cannot open file $directory/permanent.db: $! $BerkeleyDB::Error\n" ;

    $transdb = tie %transdb, 'BerkeleyDB::Btree',
            -Filename => "$directory/transient.db",
            -Flags    => DB_CREATE
                or die "Cannot open file $directory/transient.db: $! $BerkeleyDB::Error\n" ;
}




# Add a new item to the end of a queue.
sub enqueue {
    my $db = shift;
    my $queue_prefix = shift;
    my $data = shift;

    $queue_prefix .= "\\";
    my $prefixlen = length($queue_prefix);
    my $lastKey = getLastSuffixKey($db, $queue_prefix) || "${queue_prefix}00000000";

    # increment the counter by one
    $lastKey = $queue_prefix . sprintf("%08d", int(substr($lastKey, $prefixlen)) + 1);
    
    $db->db_put($lastKey, Storable::freeze($data));

    return $lastKey;
}


sub dequeue_peek {
    my $db = shift;
    my $queue_prefix = shift;

    $queue_prefix .= "\\";
    my $prefixlen = length($queue_prefix);

    my $value;
    my $cursor = $db->db_cursor();
    my $key = $queue_prefix;
    if ($cursor->c_get($key, $value, DB_SET_RANGE) == 0) {
        if (substr($key, 0, $prefixlen) eq $queue_prefix) {
            $cursor->c_close();
            $db->db_get($key, $value);
            if (wantarray) {
                return ($key, Storable::thaw( $value ));
            } else {
                return Storable::thaw( $value );
            }
        }
    }

    $cursor->c_close();
    return undef;
}


sub dequeue {
    my ($key, $val) = dequeue_peek(@_);

    my $db = shift;
    $db->db_del($key);

    return $val;
}


sub get {
    my $db = shift;
    my $key = shift;

    my $val;
    $db->db_get($key, $val);
    return Storable::thaw( $val );
}

sub put {
    my $db = shift;
    my $key = shift;
    my $val = shift;

    $db->db_put($key, Storable::freeze($val) );
}



# a general-purpose utility function for 'BerkeleyDB'...  given a prefix, find the last key with
# that prefix  (as opposed to 'DB_SET_RANGE', which makes it easy to find the first)
sub getLastSuffixKey {
    my $db = shift;
    my $prefix = shift;

    my $prefixlen = length($prefix);

    my ($next_key, $value);
    my $cursor = $db->db_cursor();
    my $key = $prefix . chr(255) x 80;        # BTree is sorted in lexical order...  hopefully this is the last possible key?
    if ($cursor->c_get($key, $value, DB_SET_RANGE) == 0) {
        if (substr($key, 0, $prefixlen) eq $prefix) {
            $cursor->c_close();
            return $key;
        } elsif ($cursor->c_get($key, $value, DB_PREV) == 0) {
            if (substr($key, 0, $prefixlen) eq $prefix) {
                $cursor->c_close();
                return $key;
            }
        }
    } elsif ($cursor->c_get($key, $value, DB_LAST) == 0) {
        if (substr($key, 0, $prefixlen) eq $prefix) {
            $cursor->c_close();
            return $key;
        }
    }
    $cursor->c_close();

    return undef;   # didn't find it
}


1;