[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({
        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 1 if $is_del;

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

sub get_next_key {
    my $self = shift;
    my ($offset) = @_;

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

    return $self->traverse_index( $temp, $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 );

    if ( $trans_id ) {
        $self->_mark_as_deleted({
            tag      => $key_tag,
            trans_id => $trans_id,
        });
    }
    else {
        my $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, $value );
            }
        }
        else {
            $self->_remove_key_offset({
                offset  => $_val_offset,
                key_md5 => $self->_apply_digest( $key ),
            });
        }
    }

    return 1;
}

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( $value_loc, $key, $value, $key );

    return 1;
}

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

    use Data::Dumper;warn Dumper $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;
}

#XXX Need to keep track of $bucket_tag->(ref_loc} and $bucket_tag->{ch}
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->{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} ),
        );


        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,
            );
        }
    }

    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", $obj->{base_offset}, 0, 0 ),
                chr(0) x ($self->{index_size} - $self->{long_size} + 2),
            );

            $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;

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