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

    #XXX Write this
    $self->_write_value({
        tag    => $key_tag,
        value  => $value,
    });

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

#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" );

    # $bucket_tag->{ref_loc} and $bucket_tag->{ch} are used in split_index()

    #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 {
        BUCKET:
        for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
            my ($key, $subloc) = $self->_get_key_subloc(
                $bucket_tag->{content}, $i,
            );

            next BUCKET if $subloc && $key ne $args->{key_md5};
            #XXX Right here, I need to create a new value, if I can
            return( $subloc, $bucket_tag );
        }
        # Right here, it looks like split_index needs to happen
        # What happens here?
    }

    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 _write_value {
    my $self = shift;
    my ($args) = @_;


}

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
230	#XXX Write this
231	$self->_write_value({
232	tag => $key_tag,
233	value => $value,
234	});
235
236	return 1;
237	}
238
239	sub _find_value_offset {
240	my $self = shift;
241	my ($args) = @_;
242
243	my $key_tag = $self->load_tag( $args->{offset} );
244
245	my @head;
246	for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
247	my ($loc, $trans_id, $is_deleted) = unpack(
248	"$self->{long_pack} C C",
249	substr( $key_tag->{content}, $i * $self->{key_size}, $self->{key_size} ),
250	);
251
252	if ( $trans_id == HEAD ) {
253	@head = ($loc, $is_deleted);
254	}
255
256	next if $loc && $args->{trans_id} != $trans_id;
257	return( $loc, $is_deleted );
258	}
259
260	return @head if $args->{allow_head};
261	return;
262	}
263
264	#XXX Need to keep track of $bucket_tag->(ref_loc} and $bucket_tag->{ch}
265	sub _find_key_offset {
266	my $self = shift;
267	my ($args) = @_;
268
269	my $bucket_tag = $self->load_tag( $args->{offset} )
270	or $self->_throw_error( "INTERNAL ERROR - Cannot find tag" );
271
272	# $bucket_tag->{ref_loc} and $bucket_tag->{ch} are used in split_index()
273
274	#XXX What happens when $ch >= $self->{hash_size} ??
275	for (my $ch = 0; $bucket_tag->{signature} ne SIG_BLIST; $ch++) {
276	my $num = ord substr($args->{key_md5}, $ch, 1);
277
278	my $ref_loc = $bucket_tag->{offset} + ($num * $self->{long_size});
279	$bucket_tag = $self->index_lookup( $bucket_tag, $num );
280
281	if (!$bucket_tag) {
282	return if !$args->{create};
283
284	my $loc = $self->_storage->request_space(
285	$self->tag_size( $self->{bucket_list_size} ),
286	);
287
288	$self->_storage->print_at( $ref_loc, pack($self->{long_pack}, $loc) );
289
290	$bucket_tag = $self->write_tag(
291	$loc, SIG_BLIST,
292	chr(0)x$self->{bucket_list_size},
293	);
294
295	$bucket_tag->{ref_loc} = $ref_loc;
296	$bucket_tag->{ch} = $ch;
297	$bucket_tag->{is_new} = 1;
298
299	last;
300	}
301
302	$bucket_tag->{ch} = $ch;
303	$bucket_tag->{ref_loc} = $ref_loc;
304	}
305
306	# Need to create a new keytag, too
307	if ( $bucket_tag->{is_new} ) {
308	my $keytag_loc = $self->_storage->request_space(
309	$self->tag_size( $self->{keyloc_size} ),
310	);
311
312	substr( $bucket_tag->{content}, 0, $self->{key_size} ) =
313	$args->{key_md5} . pack( "$self->{long_pack}", $keytag_loc );
314
315	$self->_storage->print_at( $bucket_tag->{offset}, $bucket_tag->{content} );
316
317	$self->write_tag(
318	$keytag_loc, SIG_KEYS,
319	chr(0)x$self->{keyloc_size},
320	);
321
322	return( $keytag_loc, $bucket_tag );
323	}
324	else {
325	BUCKET:
326	for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
327	my ($key, $subloc) = $self->_get_key_subloc(
328	$bucket_tag->{content}, $i,
329	);
330
331	next BUCKET if $subloc && $key ne $args->{key_md5};
332	#XXX Right here, I need to create a new value, if I can
333	return( $subloc, $bucket_tag );
334	}
335	# Right here, it looks like split_index needs to happen
336	# What happens here?
337	}
338
339	return;
340	}
341
342	sub _read_value {
343	my $self = shift;
344	my ($args) = @_;
345
346	return $self->read_from_loc( $args->{offset} );
347	}
348
349	sub _mark_as_deleted {
350	my $self = shift;
351	my ($args) = @_;
352
353	my $is_changed;
354	for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
355	my ($loc, $trans_id, $is_deleted) = unpack(
356	"$self->{long_pack} C C",
357	substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
358	);
359
360
361	if ( $trans_id == $args->{trans_id} ) {
362	substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = pack(
363	"$self->{long_pack} C C",
364	$loc, $trans_id, 1,
365	)
366	}
367	}
368
369	if ( $is_changed ) {
370	$self->_storage->print_at(
371	$args->{tag}{offset}, $args->{tag}{content},
372	);
373	}
374
375	return 1;
376	}
377
378	sub _has_keyloc_entry {
379	my $self = shift;
380	my ($args) = @_;
381
382	for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
383	my ($loc, $trans_id, $is_deleted) = unpack(
384	"$self->{long_pack} C C",
385	substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
386	);
387
388	return 1 if $trans_id == $args->{trans_id};
389	}
390
391	return;
392	}
393
394	sub _remove_key_offset {
395	my $self = shift;
396	my ($args) = @_;
397
398	my $is_changed;
399	for ( my $i = 0; $i < $self->{max_buckets}; $i++ ) {
400	my ($loc, $trans_id, $is_deleted) = unpack(
401	"$self->{long_pack} C C",
402	substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ),
403	);
404
405	if ( $trans_id == $args->{trans_id} ) {
406	substr( $args->{tag}{content}, $i * $self->{key_size}, $self->{key_size} ) = '';
407	$args->{tag}{content} .= chr(0) x $self->{key_size};
408	$is_changed = 1;
409	redo;
410	}
411	}
412
413	if ( $is_changed ) {
414	$self->_storage->print_at(
415	$args->{tag}{offset}, $args->{tag}{content},
416	);
417	}
418
419	return 1;
420	}
421
422	sub _write_value {
423	my $self = shift;
424	my ($args) = @_;
425
426
427	}
428
429	sub setup_fh {
430	my $self = shift;
431	my ($obj) = @_;
432
433	# Need to remove use of $fh here
434	my $fh = $self->_storage->{fh};
435	flock $fh, LOCK_EX;
436
437	#XXX The duplication of calculate_sizes needs to go away
438	unless ( $obj->{base_offset} ) {
439	my $bytes_read = $self->read_file_header;
440
441	$self->calculate_sizes;
442
443	##
444	# File is empty -- write header and master index
445	##
446	if (!$bytes_read) {
447	$self->_storage->audit( "# Database created on" );
448
449	$self->write_file_header;
450
451	$obj->{base_offset} = $self->_storage->request_space(
452	$self->tag_size( $self->{keyloc_size} ),
453	);
454
455	my $value_spot = $self->_storage->request_space(
456	$self->tag_size( $self->{index_size} ),
457	);
458
459	$self->write_tag(
460	$obj->{base_offset}, SIG_KEYS,
461	pack( "$self->{long_pack} C C", $obj->{base_offset}, 0, 0 ),
462	chr(0) x ($self->{index_size} - $self->{long_size} + 2),
463	);
464
465	$self->write_tag(
466	$value_spot, $obj->_type,
467	chr(0)x$self->{index_size},
468	);
469
470	# Flush the filehandle
471	my $old_fh = select $fh;
472	my $old_af = $\|; $\| = 1; $\| = $old_af;
473	select $old_fh;
474	}
475	else {
476	$obj->{base_offset} = $bytes_read;
477
478	##
479	# Get our type from master index header
480	##
481	my $tag = $self->load_tag($obj->_base_offset);
482	unless ( $tag ) {
483	flock $fh, LOCK_UN;
484	$self->_throw_error("Corrupted file, no master index record");
485	}
486
487	unless ($obj->_type eq $tag->{signature}) {
488	flock $fh, LOCK_UN;
489	$self->_throw_error("File type mismatch");
490	}
491	}
492	}
493	else {
494	$self->calculate_sizes;
495	}
496
497	#XXX We have to make sure we don't mess up when autoflush isn't turned on
498	$self->_storage->set_inode;
499
500	flock $fh, LOCK_UN;
501
502	return 1;
503	}
504
505	1;
506	__END__