[dbsrgits/DBM-Deep.git] / lib / DBM / Deep / Engine2.pm

package DBM::Deep::Engine2;

use base 'DBM::Deep::Engine';

use 5.6.0;

use strict;
use warnings;

our $VERSION = q(0.99_03);

use Fcntl qw( :DEFAULT :flock );
use Scalar::Util ();

# File-wide notes:
# * Every method in here assumes that the _storage has been appropriately
#   safeguarded. This can be anything from flock() to some sort of manual
#   mutex. But, it's the caller's responsability to make sure that this has
#   been done.

# Setup file and tag signatures.  These should never change.
sub SIG_FILE     () { 'DPDB' }
sub SIG_HEADER   () { 'h'    }
sub SIG_INTERNAL () { 'i'    }
sub SIG_HASH     () { 'H'    }
sub SIG_ARRAY    () { 'A'    }
sub SIG_NULL     () { 'N'    }
sub SIG_DATA     () { 'D'    }
sub SIG_INDEX    () { 'I'    }
sub SIG_BLIST    () { 'B'    }
sub SIG_FREE     () { 'F'    }
sub SIG_KEYS     () { 'K'    }
sub SIG_SIZE     () {  1     }

# This is the transaction ID for the HEAD
sub HEAD () { 0 }

sub read_value {
    my $self = shift;
    my ($trans_id, $base_offset, $key) = @_;
    
    my ($_val_offset, $_is_del) = $self->_find_value_offset({
        offset     => $base_offset,
        trans_id   => $trans_id,
        allow_head => 1,
    });
    die "Attempt to use a deleted value" if $_is_del;
    die "Internal error!" if !$_val_offset;

    my ($key_offset) = $self->_find_key_offset({
        offset  => $_val_offset,
        key_md5 => $self->_apply_digest( $key ),
    });
    return if !$key_offset;

    my ($val_offset, $is_del) = $self->_find_value_offset({
        offset     => $key_offset,
        trans_id   => $trans_id,
        allow_head => 1,
    });
    return if $is_del;
    die "Internal error!" if !$val_offset;

    return $self->_read_value({
        keyloc => $key_offset,
        offset => $val_offset,
    });
}

sub key_exists {
    my $self = shift;
    my ($trans_id, $base_offset, $key) = @_;
    
    my ($_val_offset, $_is_del) = $self->_find_value_offset({
        offset     => $base_offset,
        trans_id   => $trans_id,
        allow_head => 1,
    });
    die "Attempt to use a deleted value" if $_is_del;
    die "Internal error!" if !$_val_offset;

    my ($key_offset) = $self->_find_key_offset({
        offset  => $_val_offset,
        key_md5 => $self->_apply_digest( $key ),
    });
    return '' if !$key_offset;

    my ($val_offset, $is_del) = $self->_find_value_offset({
        offset     => $key_offset,
        trans_id   => $trans_id,
        allow_head => 1,
    });

    return '' if $is_del;

    die "Internal error!" if !$_val_offset;
    return 1;
}

sub get_next_key {
    my $self = shift;
    my ($trans_id, $base_offset) = @_;

    my ($_val_offset, $_is_del) = $self->_find_value_offset({
        offset     => $base_offset,
        trans_id   => $trans_id,
        allow_head => 1,
    });
    die "Attempt to use a deleted value" if $_is_del;
    die "Internal error!" if !$_val_offset;

    # If the previous key was not specifed, start at the top and
    # return the first one found.
    my $temp;
    if ( @_ > 2 ) {
        $temp = {
            prev_md5    => $self->_apply_digest($_[2]),
            return_next => 0,
        };
    }
    else {
        $temp = {
            prev_md5    => chr(0) x $self->{hash_size},
            return_next => 1,
        };
    }

    return $self->traverse_index( $temp, $_val_offset, 0 );
}

sub delete_key {
    my $self = shift;
    my ($trans_id, $base_offset, $key) = @_;

    my ($_val_offset, $_is_del) = $self->_find_value_offset({
        offset     => $base_offset,
        trans_id   => $trans_id,
        allow_head => 1,
    });
    die "Attempt to use a deleted value" if $_is_del;
    die "Internal error!" if !$_val_offset;

    my ($key_offset, $bucket_tag) = $self->_find_key_offset({
        offset  => $_val_offset,
        key_md5 => $self->_apply_digest( $key ),
    });
    return if !$key_offset;

    my $key_tag = $self->load_tag( $key_offset );

    my $value = $self->read_value( $trans_id, $base_offset, $key );
    if ( $trans_id ) {
        $self->_mark_as_deleted({
            tag      => $key_tag,
            trans_id => $trans_id,
        });
    }
    else {
        if ( my @transactions = $self->_storage->current_transactions ) {
            foreach my $other_trans_id ( @transactions ) {
                next if $self->_has_keyloc_entry({
                    tag      => $key_tag,
                    trans_id => $other_trans_id,
                });
                $self->write_value( $other_trans_id, $base_offset, $key, $value );
            }
        }

        $self->_mark_as_deleted({
            tag      => $key_tag,
            trans_id => $trans_id,
        });
#        $self->_remove_key_offset({
#            offset  => $_val_offset,
#            key_md5 => $self->_apply_digest( $key ),
#        });
    }

    return $value;
}

sub write_value {
    my $self = shift;
    my ($trans_id, $base_offset, $key, $value) = @_;

    # This verifies that only supported values will be stored.
    {
        my $r = Scalar::Util::reftype( $value );

        last if !defined $r;
        last if $r eq 'HASH';
        last if $r eq 'ARRAY';

        $self->_throw_error(
            "Storage of references of type '$r' is not supported."
        );
    }

    my ($_val_offset, $_is_del) = $self->_find_value_offset({
        offset     => $base_offset,
        trans_id   => $trans_id,
        allow_head => 1,
    });
    die "Attempt to use a deleted value" if $_is_del;
    die "Internal error!" if !$_val_offset;

    my ($key_offset, $bucket_tag) = $self->_find_key_offset({
        offset  => $_val_offset,
        key_md5 => $self->_apply_digest( $key ),
        create  => 1,
    });
    die "Cannot find/create new key offset!" if !$key_offset;

    my $key_tag = $self->load_tag( $key_offset );

    if ( $trans_id ) {
        if ( $bucket_tag->{is_new} ) {
            # Must mark the HEAD as deleted because it doesn't exist
            $self->_mark_as_deleted({
                tag      => $key_tag,
                trans_id => HEAD,
            });
        }
    }
    else {
        # If the HEAD isn't new, then we must take other transactions
        # into account. If it is, then there can be no other transactions.
        if ( !$bucket_tag->{is_new} ) {
            my $old_value = $self->read_value( $trans_id, $base_offset, $key );
            if ( my @transactions = $self->_storage->current_transactions ) {
                foreach my $other_trans_id ( @transactions ) {
                    next if $self->_has_keyloc_entry({
                        tag      => $key_tag,
                        trans_id => $other_trans_id,
                    });
                    $self->write_value( $other_trans_id, $base_offset, $key, $old_value );
                }
            }
        }
    }

    my $value_loc = $self->_storage->request_space( 
        $self->_length_needed( $value, $key ),
    );

    $self->_add_key_offset({
        tag      => $key_tag,
        trans_id => $trans_id,
        loc      => $value_loc,
    });

    $self->_write_value( $key_offset, $value_loc, $key, $value, $key );

    return 1;
}

sub _find_value_offset {
    my $self = shift;
    my ($args) = @_;

    my $key_tag = $self->load_tag( $args->{offset} );

    my @head;
    for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
        my ($loc, $trans_id, $is_deleted) = unpack(
            "$self->{long_pack} C C",
            substr( $key_tag->{content}, $i * $self->{key_size}, $self->{key_size} ),
        );

        if ( $trans_id == HEAD ) {
            @head = ($loc, $is_deleted);
        }

        next if $loc && $args->{trans_id} != $trans_id;
        return( $loc, $is_deleted );
    }

    return @head if $args->{allow_head};
    return;
}

sub _find_key_offset {
    my $self = shift;
    my ($args) = @_;

    my $bucket_tag = $self->load_tag( $args->{offset} )
        or $self->_throw_error( "INTERNAL ERROR - Cannot find tag" );

    #XXX What happens when $ch >= $self->{hash_size} ??
    for (my $ch = 0; $bucket_tag->{signature} ne SIG_BLIST; $ch++) {
        my $num = ord substr($args->{key_md5}, $ch, 1);

        my $ref_loc = $bucket_tag->{offset} + ($num * $self->{long_size});
        $bucket_tag = $self->index_lookup( $bucket_tag, $num );

        if (!$bucket_tag) {
            return if !$args->{create};

            my $loc = $self->_storage->request_space(
                $self->tag_size( $self->{bucket_list_size} ),
            );

            $self->_storage->print_at( $ref_loc, pack($self->{long_pack}, $loc) );

            $bucket_tag = $self->write_tag(
                $loc, SIG_BLIST,
                chr(0)x$self->{bucket_list_size},
            );

            $bucket_tag->{ref_loc} = $ref_loc;
            $bucket_tag->{ch} = $ch;
            $bucket_tag->{is_new} = 1;

            last;
        }

        $bucket_tag->{ch} = $ch;
        $bucket_tag->{ref_loc} = $ref_loc;
    }

    # Need to create a new keytag, too
    if ( $bucket_tag->{is_new} ) {
        my $keytag_loc = $self->_storage->request_space(
            $self->tag_size( $self->{keyloc_size} ),
        );

        substr( $bucket_tag->{content}, 0, $self->{key_size} ) =
            $args->{key_md5} . pack( "$self->{long_pack}", $keytag_loc );

        $self->_storage->print_at( $bucket_tag->{offset}, $bucket_tag->{content} );

        $self->write_tag(
            $keytag_loc, SIG_KEYS,
            chr(0)x$self->{keyloc_size},
        );

        return( $keytag_loc, $bucket_tag );
    }
    else {
        my ($key, $subloc, $index);
        BUCKET:
        for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
            ($key, $subloc) = $self->_get_key_subloc(
                $bucket_tag->{content}, $i,
            );

            next BUCKET if $subloc && $key ne $args->{key_md5};

            # Keep track of where we are, in case we need to create a new
            # entry.
            $index = $i;
            last;
        }

        # Either we have a subloc to return or we don't want to create a new
        # entry. Either way, we need to return now.
        return ($subloc, $bucket_tag) if $subloc || !$args->{create};

        my $keytag_loc = $self->_storage->request_space(
            $self->tag_size( $self->{keyloc_size} ),
        );

        # There's space left in this bucket
        if ( defined $index ) {
            substr( $bucket_tag->{content}, $index * $self->{key_size}, $self->{key_size} ) =
                $args->{key_md5} . pack( "$self->{long_pack}", $keytag_loc );

            $self->_storage->print_at( $bucket_tag->{offset}, $bucket_tag->{content} );
        }
        # We need to split the index
        else {
            $self->split_index( $bucket_tag, $args->{key_md5}, $keytag_loc );
        }

        $self->write_tag(
            $keytag_loc, SIG_KEYS,
            chr(0)x$self->{keyloc_size},
        );

        return( $keytag_loc, $bucket_tag );
    }

    return;
}

sub _read_value {
    my $self = shift;
    my ($args) = @_;

    return $self->read_from_loc( $args->{keyloc}, $args->{offset} );
}

sub _mark_as_deleted {
    my $self = shift;
    my ($args) = @_;

    my $is_changed;
    for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
        my ($loc, $trans_id, $is_deleted) = unpack(
            "$self->{long_pack} C C",
            substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
        );

        last unless $loc || $is_deleted;

        if ( $trans_id == $args->{trans_id} ) {
            substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = pack(
                "$self->{long_pack} C C",
                $loc, $trans_id, 1,
            );
            $is_changed = 1;
            last;
        }
    }

    if ( $is_changed ) {
        $self->_storage->print_at(
            $args->{tag}{offset}, $args->{tag}{content},
        );
    }

    return 1;
}

sub _has_keyloc_entry {
    my $self = shift;
    my ($args) = @_;

    for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
        my ($loc, $trans_id, $is_deleted) = unpack(
            "$self->{long_pack} C C",
            substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
        );

        return 1 if $trans_id == $args->{trans_id};
    }

    return;
}

sub _remove_key_offset {
    my $self = shift;
    my ($args) = @_;

    my $is_changed;
    for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
        my ($loc, $trans_id, $is_deleted) = unpack(
            "$self->{long_pack} C C",
            substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
        );

        if ( $trans_id == $args->{trans_id} ) {
            substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = '';
            $args->{tag}{content} .= chr(0) x $self->{key_size};
            $is_changed = 1;
            redo;
        }
    }

    if ( $is_changed ) {
        $self->_storage->print_at(
            $args->{tag}{offset}, $args->{tag}{content},
        );
    }

    return 1;
}

sub _add_key_offset {
    my $self = shift;
    my ($args) = @_;

    my $is_changed;
    for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
        my ($loc, $trans_id, $is_deleted) = unpack(
            "$self->{long_pack} C C",
            substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
        );

        if ( $trans_id == $args->{trans_id} || (!$loc && !$is_deleted) ) {
            substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = pack(
                "$self->{long_pack} C C",
                $args->{loc}, $args->{trans_id}, 0,
            );
            $is_changed = 1;
            last;
        }
    }

    if ( $is_changed ) {
        $self->_storage->print_at(
            $args->{tag}{offset}, $args->{tag}{content},
        );
    }
    else {
        die "Why didn't _add_key_offset() change something?!\n";
    }

    return 1;
}

sub setup_fh {
    my $self = shift;
    my ($obj) = @_;

    # Need to remove use of $fh here
    my $fh = $self->_storage->{fh};
    flock $fh, LOCK_EX;

    #XXX The duplication of calculate_sizes needs to go away
    unless ( $obj->{base_offset} ) {
        my $bytes_read = $self->read_file_header;

        $self->calculate_sizes;

        ##
        # File is empty -- write header and master index
        ##
        if (!$bytes_read) {
            $self->_storage->audit( "# Database created on" );

            $self->write_file_header;

            $obj->{base_offset} = $self->_storage->request_space(
                $self->tag_size( $self->{keyloc_size} ),
            );

            my $value_spot = $self->_storage->request_space(
                $self->tag_size( $self->{index_size} ),
            );

            $self->write_tag(
                $obj->{base_offset}, SIG_KEYS,
                pack( "$self->{long_pack} C C", $value_spot, HEAD, 0 ),
                chr(0) x ($self->{index_size} - $self->{key_size}),
            );

            $self->write_tag(
                $value_spot, $obj->_type,
                chr(0)x$self->{index_size},
            );

            # Flush the filehandle
            my $old_fh = select $fh;
            my $old_af = $|; $| = 1; $| = $old_af;
            select $old_fh;
        }
        else {
            $obj->{base_offset} = $bytes_read;

            my ($_val_offset, $_is_del) = $self->_find_value_offset({
                offset     => $obj->{base_offset},
                trans_id   => HEAD,
                allow_head => 1,
            });
            die "Attempt to use a deleted value" if $_is_del;
            die "Internal error!" if !$_val_offset;

            ##
            # Get our type from master index header
            ##
            my $tag = $self->load_tag($_val_offset);
            unless ( $tag ) {
                flock $fh, LOCK_UN;
                $self->_throw_error("Corrupted file, no master index record");
            }

            unless ($obj->_type eq $tag->{signature}) {
                flock $fh, LOCK_UN;
                $self->_throw_error("File type mismatch");
            }
        }
    }
    else {
        $self->calculate_sizes;
    }

    #XXX We have to make sure we don't mess up when autoflush isn't turned on
    $self->_storage->set_inode;

    flock $fh, LOCK_UN;

    return 1;
}

1;
__END__
Commit	Line	Data
fb451ba6	1	package DBM::Deep::Engine2;
	2
	3	use base 'DBM::Deep::Engine';
	4
	5	use 5.6.0;
	6
	7	use strict;
	8	use warnings;
	9
	10	our $VERSION = q(0.99_03);
	11
	12	use Fcntl qw( :DEFAULT :flock );
	13	use Scalar::Util ();
	14
	15	# File-wide notes:
	16	# * Every method in here assumes that the _storage has been appropriately
	17	# safeguarded. This can be anything from flock() to some sort of manual
	18	# mutex. But, it's the caller's responsability to make sure that this has
	19	# been done.
	20
	21	# Setup file and tag signatures. These should never change.
	22	sub SIG_FILE () { 'DPDB' }
	23	sub SIG_HEADER () { 'h' }
	24	sub SIG_INTERNAL () { 'i' }
	25	sub SIG_HASH () { 'H' }
	26	sub SIG_ARRAY () { 'A' }
	27	sub SIG_NULL () { 'N' }
	28	sub SIG_DATA () { 'D' }
	29	sub SIG_INDEX () { 'I' }
	30	sub SIG_BLIST () { 'B' }
	31	sub SIG_FREE () { 'F' }
	32	sub SIG_KEYS () { 'K' }
	33	sub SIG_SIZE () { 1 }
	34
	35	# This is the transaction ID for the HEAD
	36	sub HEAD () { 0 }
	37
	38	sub read_value {
	39	my $self = shift;
	40	my ($trans_id, $base_offset, $key) = @_;
	41
	42	my ($_val_offset, $_is_del) = $self->_find_value_offset({
	43	offset => $base_offset,
	44	trans_id => $trans_id,
	45	allow_head => 1,
	46	});
	47	die "Attempt to use a deleted value" if $_is_del;
	48	die "Internal error!" if !$_val_offset;
	49
	50	my ($key_offset) = $self->_find_key_offset({
	51	offset => $_val_offset,
	52	key_md5 => $self->_apply_digest( $key ),
	53	});
	54	return if !$key_offset;
	55
	56	my ($val_offset, $is_del) = $self->_find_value_offset({
	57	offset => $key_offset,
	58	trans_id => $trans_id,
	59	allow_head => 1,
	60	});
	61	return if $is_del;
	62	die "Internal error!" if !$val_offset;
	63
	64	return $self->_read_value({
129ea236	65	keyloc => $key_offset,
fb451ba6	66	offset => $val_offset,
	67	});
	68	}
	69
	70	sub key_exists {
	71	my $self = shift;
	72	my ($trans_id, $base_offset, $key) = @_;
	73
	74	my ($_val_offset, $_is_del) = $self->_find_value_offset({
	75	offset => $base_offset,
	76	trans_id => $trans_id,
	77	allow_head => 1,
	78	});
	79	die "Attempt to use a deleted value" if $_is_del;
	80	die "Internal error!" if !$_val_offset;
	81
	82	my ($key_offset) = $self->_find_key_offset({
	83	offset => $_val_offset,
	84	key_md5 => $self->_apply_digest( $key ),
	85	});
129ea236	86	return '' if !$key_offset;
fb451ba6	87
	88	my ($val_offset, $is_del) = $self->_find_value_offset({
	89	offset => $key_offset,
	90	trans_id => $trans_id,
	91	allow_head => 1,
	92	});
	93
129ea236	94	return '' if $is_del;
fb451ba6	95
fb451ba6	96	die "Internal error!" if !$_val_offset;
129ea236	97	return 1;
fb451ba6	98	}
	99
	100	sub get_next_key {
	101	my $self = shift;
129ea236	102	my ($trans_id, $base_offset) = @_;
	103
	104	my ($_val_offset, $_is_del) = $self->_find_value_offset({
	105	offset => $base_offset,
	106	trans_id => $trans_id,
	107	allow_head => 1,
	108	});
	109	die "Attempt to use a deleted value" if $_is_del;
	110	die "Internal error!" if !$_val_offset;
fb451ba6	111
	112	# If the previous key was not specifed, start at the top and
	113	# return the first one found.
	114	my $temp;
129ea236	115	if ( @_ > 2 ) {
fb451ba6	116	$temp = {
129ea236	117	prev_md5 => $self->_apply_digest($_[2]),
fb451ba6	118	return_next => 0,
	119	};
	120	}
	121	else {
	122	$temp = {
	123	prev_md5 => chr(0) x $self->{hash_size},
	124	return_next => 1,
	125	};
	126	}
	127
129ea236	128	return $self->traverse_index( $temp, $_val_offset, 0 );
fb451ba6	129	}
	130
	131	sub delete_key {
	132	my $self = shift;
	133	my ($trans_id, $base_offset, $key) = @_;
	134
	135	my ($_val_offset, $_is_del) = $self->_find_value_offset({
	136	offset => $base_offset,
	137	trans_id => $trans_id,
	138	allow_head => 1,
	139	});
	140	die "Attempt to use a deleted value" if $_is_del;
	141	die "Internal error!" if !$_val_offset;
	142
	143	my ($key_offset, $bucket_tag) = $self->_find_key_offset({
	144	offset => $_val_offset,
	145	key_md5 => $self->_apply_digest( $key ),
	146	});
	147	return if !$key_offset;
	148
	149	my $key_tag = $self->load_tag( $key_offset );
	150
129ea236	151	my $value = $self->read_value( $trans_id, $base_offset, $key );
fb451ba6	152	if ( $trans_id ) {
	153	$self->_mark_as_deleted({
	154	tag => $key_tag,
	155	trans_id => $trans_id,
	156	});
	157	}
	158	else {
fb451ba6	159	if ( my @transactions = $self->_storage->current_transactions ) {
	160	foreach my $other_trans_id ( @transactions ) {
	161	next if $self->_has_keyloc_entry({
	162	tag => $key_tag,
	163	trans_id => $other_trans_id,
	164	});
	165	$self->write_value( $other_trans_id, $base_offset, $key, $value );
	166	}
	167	}
129ea236	168
	169	$self->_mark_as_deleted({
	170	tag => $key_tag,
	171	trans_id => $trans_id,
	172	});
	173	# $self->_remove_key_offset({
	174	# offset => $_val_offset,
	175	# key_md5 => $self->_apply_digest( $key ),
	176	# });
fb451ba6	177	}
fb451ba6	178
129ea236	179	return $value;
fb451ba6	180	}
	181
	182	sub write_value {
	183	my $self = shift;
	184	my ($trans_id, $base_offset, $key, $value) = @_;
	185
	186	# This verifies that only supported values will be stored.
	187	{
	188	my $r = Scalar::Util::reftype( $value );
	189
	190	last if !defined $r;
	191	last if $r eq 'HASH';
	192	last if $r eq 'ARRAY';
	193
	194	$self->_throw_error(
	195	"Storage of references of type '$r' is not supported."
	196	);
	197	}
	198
	199	my ($_val_offset, $_is_del) = $self->_find_value_offset({
	200	offset => $base_offset,
	201	trans_id => $trans_id,
	202	allow_head => 1,
	203	});
	204	die "Attempt to use a deleted value" if $_is_del;
	205	die "Internal error!" if !$_val_offset;
	206
	207	my ($key_offset, $bucket_tag) = $self->_find_key_offset({
	208	offset => $_val_offset,
	209	key_md5 => $self->_apply_digest( $key ),
	210	create => 1,
	211	});
	212	die "Cannot find/create new key offset!" if !$key_offset;
	213
	214	my $key_tag = $self->load_tag( $key_offset );
	215
	216	if ( $trans_id ) {
	217	if ( $bucket_tag->{is_new} ) {
	218	# Must mark the HEAD as deleted because it doesn't exist
	219	$self->_mark_as_deleted({
	220	tag => $key_tag,
	221	trans_id => HEAD,
	222	});
	223	}
	224	}
	225	else {
	226	# If the HEAD isn't new, then we must take other transactions
	227	# into account. If it is, then there can be no other transactions.
	228	if ( !$bucket_tag->{is_new} ) {
	229	my $old_value = $self->read_value( $trans_id, $base_offset, $key );
	230	if ( my @transactions = $self->_storage->current_transactions ) {
	231	foreach my $other_trans_id ( @transactions ) {
	232	next if $self->_has_keyloc_entry({
	233	tag => $key_tag,
	234	trans_id => $other_trans_id,
	235	});
	236	$self->write_value( $other_trans_id, $base_offset, $key, $old_value );
	237	}
	238	}
	239	}
	240	}
	241
40956c06	242	my $value_loc = $self->_storage->request_space(
	243	$self->_length_needed( $value, $key ),
	244	);
	245
	246	$self->_add_key_offset({
	247	tag => $key_tag,
	248	trans_id => $trans_id,
	249	loc => $value_loc,
fb451ba6	250	});
fb451ba6	251
129ea236	252	$self->_write_value( $key_offset, $value_loc, $key, $value, $key );
40956c06	253
fb451ba6	254	return 1;
	255	}
	256
	257	sub _find_value_offset {
	258	my $self = shift;
	259	my ($args) = @_;
	260
	261	my $key_tag = $self->load_tag( $args->{offset} );
	262
	263	my @head;
	264	for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
	265	my ($loc, $trans_id, $is_deleted) = unpack(
	266	"$self->{long_pack} C C",
	267	substr( $key_tag->{content}, $i * $self->{key_size}, $self->{key_size} ),
	268	);
	269
	270	if ( $trans_id == HEAD ) {
	271	@head = ($loc, $is_deleted);
	272	}
	273
	274	next if $loc && $args->{trans_id} != $trans_id;
	275	return( $loc, $is_deleted );
	276	}
	277
	278	return @head if $args->{allow_head};
	279	return;
	280	}
	281
fb451ba6	282	sub _find_key_offset {
	283	my $self = shift;
	284	my ($args) = @_;
	285
	286	my $bucket_tag = $self->load_tag( $args->{offset} )
	287	or $self->_throw_error( "INTERNAL ERROR - Cannot find tag" );
	288
fb451ba6	289	#XXX What happens when $ch >= $self->{hash_size} ??
	290	for (my $ch = 0; $bucket_tag->{signature} ne SIG_BLIST; $ch++) {
	291	my $num = ord substr($args->{key_md5}, $ch, 1);
	292
	293	my $ref_loc = $bucket_tag->{offset} + ($num * $self->{long_size});
	294	$bucket_tag = $self->index_lookup( $bucket_tag, $num );
	295
	296	if (!$bucket_tag) {
	297	return if !$args->{create};
	298
	299	my $loc = $self->_storage->request_space(
	300	$self->tag_size( $self->{bucket_list_size} ),
	301	);
	302
	303	$self->_storage->print_at( $ref_loc, pack($self->{long_pack}, $loc) );
	304
	305	$bucket_tag = $self->write_tag(
	306	$loc, SIG_BLIST,
	307	chr(0)x$self->{bucket_list_size},
	308	);
	309
	310	$bucket_tag->{ref_loc} = $ref_loc;
	311	$bucket_tag->{ch} = $ch;
	312	$bucket_tag->{is_new} = 1;
	313
	314	last;
	315	}
	316
	317	$bucket_tag->{ch} = $ch;
	318	$bucket_tag->{ref_loc} = $ref_loc;
	319	}
	320
	321	# Need to create a new keytag, too
	322	if ( $bucket_tag->{is_new} ) {
	323	my $keytag_loc = $self->_storage->request_space(
	324	$self->tag_size( $self->{keyloc_size} ),
	325	);
	326
	327	substr( $bucket_tag->{content}, 0, $self->{key_size} ) =
	328	$args->{key_md5} . pack( "$self->{long_pack}", $keytag_loc );
	329
	330	$self->_storage->print_at( $bucket_tag->{offset}, $bucket_tag->{content} );
	331
	332	$self->write_tag(
	333	$keytag_loc, SIG_KEYS,
	334	chr(0)x$self->{keyloc_size},
	335	);
	336
	337	return( $keytag_loc, $bucket_tag );
	338	}
	339	else {
40956c06	340	my ($key, $subloc, $index);
fb451ba6	341	BUCKET:
fb451ba6	342	for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
40956c06	343	($key, $subloc) = $self->_get_key_subloc(
fb451ba6	344	$bucket_tag->{content}, $i,
	345	);
	346
	347	next BUCKET if $subloc && $key ne $args->{key_md5};
40956c06	348
	349	# Keep track of where we are, in case we need to create a new
	350	# entry.
	351	$index = $i;
	352	last;
fb451ba6	353	}
40956c06	354
	355	# Either we have a subloc to return or we don't want to create a new
	356	# entry. Either way, we need to return now.
	357	return ($subloc, $bucket_tag) if $subloc \|\| !$args->{create};
	358
	359	my $keytag_loc = $self->_storage->request_space(
	360	$self->tag_size( $self->{keyloc_size} ),
	361	);
	362
	363	# There's space left in this bucket
	364	if ( defined $index ) {
	365	substr( $bucket_tag->{content}, $index * $self->{key_size}, $self->{key_size} ) =
	366	$args->{key_md5} . pack( "$self->{long_pack}", $keytag_loc );
	367
	368	$self->_storage->print_at( $bucket_tag->{offset}, $bucket_tag->{content} );
	369	}
	370	# We need to split the index
	371	else {
	372	$self->split_index( $bucket_tag, $args->{key_md5}, $keytag_loc );
	373	}
	374
	375	$self->write_tag(
	376	$keytag_loc, SIG_KEYS,
	377	chr(0)x$self->{keyloc_size},
	378	);
	379
	380	return( $keytag_loc, $bucket_tag );
fb451ba6	381	}
	382
	383	return;
	384	}
	385
	386	sub _read_value {
	387	my $self = shift;
	388	my ($args) = @_;
	389
129ea236	390	return $self->read_from_loc( $args->{keyloc}, $args->{offset} );
fb451ba6	391	}
	392
	393	sub _mark_as_deleted {
	394	my $self = shift;
	395	my ($args) = @_;
	396
	397	my $is_changed;
	398	for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
	399	my ($loc, $trans_id, $is_deleted) = unpack(
	400	"$self->{long_pack} C C",
	401	substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
	402	);
	403
129ea236	404	last unless $loc \|\| $is_deleted;
fb451ba6	405
	406	if ( $trans_id == $args->{trans_id} ) {
	407	substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = pack(
	408	"$self->{long_pack} C C",
	409	$loc, $trans_id, 1,
40956c06	410	);
129ea236	411	$is_changed = 1;
129ea236	412	last;
fb451ba6	413	}
	414	}
	415
	416	if ( $is_changed ) {
	417	$self->_storage->print_at(
	418	$args->{tag}{offset}, $args->{tag}{content},
	419	);
	420	}
	421
	422	return 1;
	423	}
	424
	425	sub _has_keyloc_entry {
	426	my $self = shift;
	427	my ($args) = @_;
	428
	429	for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
	430	my ($loc, $trans_id, $is_deleted) = unpack(
	431	"$self->{long_pack} C C",
	432	substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
	433	);
	434
	435	return 1 if $trans_id == $args->{trans_id};
	436	}
	437
	438	return;
	439	}
	440
	441	sub _remove_key_offset {
	442	my $self = shift;
	443	my ($args) = @_;
	444
	445	my $is_changed;
	446	for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
	447	my ($loc, $trans_id, $is_deleted) = unpack(
	448	"$self->{long_pack} C C",
	449	substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
	450	);
	451
	452	if ( $trans_id == $args->{trans_id} ) {
	453	substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = '';
	454	$args->{tag}{content} .= chr(0) x $self->{key_size};
	455	$is_changed = 1;
	456	redo;
	457	}
	458	}
	459
	460	if ( $is_changed ) {
	461	$self->_storage->print_at(
	462	$args->{tag}{offset}, $args->{tag}{content},
	463	);
	464	}
	465
	466	return 1;
	467	}
	468
40956c06	469	sub _add_key_offset {
fb451ba6	470	my $self = shift;
	471	my ($args) = @_;
	472
40956c06	473	my $is_changed;
	474	for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
	475	my ($loc, $trans_id, $is_deleted) = unpack(
	476	"$self->{long_pack} C C",
	477	substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
	478	);
fb451ba6	479
40956c06	480	if ( $trans_id == $args->{trans_id} \|\| (!$loc && !$is_deleted) ) {
	481	substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = pack(
	482	"$self->{long_pack} C C",
	483	$args->{loc}, $args->{trans_id}, 0,
	484	);
	485	$is_changed = 1;
	486	last;
	487	}
	488	}
	489
	490	if ( $is_changed ) {
	491	$self->_storage->print_at(
	492	$args->{tag}{offset}, $args->{tag}{content},
	493	);
	494	}
	495	else {
	496	die "Why didn't _add_key_offset() change something?!\n";
	497	}
	498
	499	return 1;
fb451ba6	500	}
	501
	502	sub setup_fh {
	503	my $self = shift;
	504	my ($obj) = @_;
	505
	506	# Need to remove use of $fh here
	507	my $fh = $self->_storage->{fh};
	508	flock $fh, LOCK_EX;
	509
	510	#XXX The duplication of calculate_sizes needs to go away
	511	unless ( $obj->{base_offset} ) {
	512	my $bytes_read = $self->read_file_header;
	513
	514	$self->calculate_sizes;
	515
	516	##
	517	# File is empty -- write header and master index
	518	##
	519	if (!$bytes_read) {
	520	$self->_storage->audit( "# Database created on" );
	521
	522	$self->write_file_header;
	523
	524	$obj->{base_offset} = $self->_storage->request_space(
	525	$self->tag_size( $self->{keyloc_size} ),
	526	);
	527
	528	my $value_spot = $self->_storage->request_space(
	529	$self->tag_size( $self->{index_size} ),
	530	);
	531
	532	$self->write_tag(
	533	$obj->{base_offset}, SIG_KEYS,
129ea236	534	pack( "$self->{long_pack} C C", $value_spot, HEAD, 0 ),
129ea236	535	chr(0) x ($self->{index_size} - $self->{key_size}),
fb451ba6	536	);
	537
	538	$self->write_tag(
	539	$value_spot, $obj->_type,
	540	chr(0)x$self->{index_size},
	541	);
	542
	543	# Flush the filehandle
	544	my $old_fh = select $fh;
	545	my $old_af = $\|; $\| = 1; $\| = $old_af;
	546	select $old_fh;
	547	}
	548	else {
	549	$obj->{base_offset} = $bytes_read;
	550
129ea236	551	my ($_val_offset, $_is_del) = $self->_find_value_offset({
	552	offset => $obj->{base_offset},
	553	trans_id => HEAD,
	554	allow_head => 1,
	555	});
	556	die "Attempt to use a deleted value" if $_is_del;
	557	die "Internal error!" if !$_val_offset;
	558
fb451ba6	559	##
	560	# Get our type from master index header
	561	##
129ea236	562	my $tag = $self->load_tag($_val_offset);
fb451ba6	563	unless ( $tag ) {
	564	flock $fh, LOCK_UN;
	565	$self->_throw_error("Corrupted file, no master index record");
	566	}
	567
	568	unless ($obj->_type eq $tag->{signature}) {
	569	flock $fh, LOCK_UN;
	570	$self->_throw_error("File type mismatch");
	571	}
	572	}
	573	}
	574	else {
	575	$self->calculate_sizes;
	576	}
	577
	578	#XXX We have to make sure we don't mess up when autoflush isn't turned on
	579	$self->_storage->set_inode;
	580
	581	flock $fh, LOCK_UN;
	582
	583	return 1;
	584	}
	585
	586	1;
	587	__END__