[dbsrgits/DBM-Deep.git] / lib / DBM / Deep / Sector / File / Reference.pm

package DBM::Deep::Sector::File::Reference;

use 5.006_000;

use strict;
use warnings FATAL => 'all';

use base qw( DBM::Deep::Sector::File::Data );

my $STALE_SIZE = 2;

# Please refer to the pack() documentation for further information
my %StP = (
    1 => 'C', # Unsigned char value (no order needed as it's just one byte)
    2 => 'n', # Unsigned short in "network" (big-endian) order
    4 => 'N', # Unsigned long in "network" (big-endian) order
    8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent)
);

sub _init {
    my $self = shift;

    my $e = $self->engine;

    unless ( $self->offset ) {
        my $classname = Scalar::Util::blessed( delete $self->{data} );
        my $leftover = $self->size - $self->base_size - 3 * $e->byte_size;

        my $class_offset = 0;
        if ( defined $classname ) {
            my $class_sector = DBM::Deep::Sector::File::Scalar->new({
                engine => $e,
                data   => $classname,
            });
            $class_offset = $class_sector->offset;
        }

        $self->{offset} = $e->_request_data_sector( $self->size );
        $e->storage->print_at( $self->offset, $self->type ); # Sector type
        # Skip staleness counter
        $e->storage->print_at( $self->offset + $self->base_size,
            pack( $StP{$e->byte_size}, 0 ),             # Index/BList loc
            pack( $StP{$e->byte_size}, $class_offset ), # Classname loc
            pack( $StP{$e->byte_size}, 1 ),             # Initial refcount
            chr(0) x $leftover,                         # Zero-fill the rest
        );
    }
    else {
        $self->{type} = $e->storage->read_at( $self->offset, 1 );
    }

    $self->{staleness} = unpack(
        $StP{$STALE_SIZE},
        $e->storage->read_at( $self->offset + $e->SIG_SIZE, $STALE_SIZE ),
    );

    return;
}

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

    # Assume that the head is not allowed unless otherwise specified.
    $args->{allow_head} = 0 unless exists $args->{allow_head};

    # Assume we don't create a new blist location unless otherwise specified.
    $args->{create} = 0 unless exists $args->{create};

    my $blist = $self->get_bucket_list({
        key_md5 => $args->{key_md5},
        key => $args->{key},
        create  => $args->{create},
    });
    return unless $blist && $blist->{found};

    # At this point, $blist knows where the md5 is. What it -doesn't- know yet
    # is whether or not this transaction has this key. That's part of the next
    # function call.
    my $location = $blist->get_data_location_for({
        allow_head => $args->{allow_head},
    }) or return;

    return $location;
}

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

    my $location = $self->get_data_location_for( $args )
        or return;

    return $self->engine->load_sector( $location );
}

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

    my $blist = $self->get_bucket_list({
        key_md5 => $args->{key_md5},
        key => $args->{key},
        create  => 1,
    }) or DBM::Deep->_throw_error( "How did write_data fail (no blist)?!" );

    # Handle any transactional bookkeeping.
    if ( $self->engine->trans_id ) {
        if ( ! $blist->has_md5 ) {
            $blist->mark_deleted({
                trans_id => 0,
            });
        }
    }
    else {
        my @trans_ids = $self->engine->get_running_txn_ids;
        if ( $blist->has_md5 ) {
            if ( @trans_ids ) {
                my $old_value = $blist->get_data_for;
                foreach my $other_trans_id ( @trans_ids ) {
                    next if $blist->get_data_location_for({
                        trans_id   => $other_trans_id,
                        allow_head => 0,
                    });
                    $blist->write_md5({
                        trans_id => $other_trans_id,
                        key      => $args->{key},
                        key_md5  => $args->{key_md5},
                        value    => $old_value->clone,
                    });
                }
            }
        }
        else {
            if ( @trans_ids ) {
                foreach my $other_trans_id ( @trans_ids ) {
                    #XXX This doesn't seem to possible to ever happen . . .
                    next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 });
                    $blist->mark_deleted({
                        trans_id => $other_trans_id,
                    });
                }
            }
        }
    }

    #XXX Is this safe to do transactionally?
    # Free the place we're about to write to.
    if ( $blist->get_data_location_for({ allow_head => 0 }) ) {
        $blist->get_data_for({ allow_head => 0 })->free;
    }

    $blist->write_md5({
        key      => $args->{key},
        key_md5  => $args->{key_md5},
        value    => $args->{value},
    });
}

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

    # This can return nothing if we are deleting an entry in a hashref that was
    # auto-vivified as part of the delete process. For example:
    #     my $x = {};
    #     delete $x->{foo}{bar};
    my $blist = $self->get_bucket_list({
        key_md5 => $args->{key_md5},
    }) or return;

    # Save the location so that we can free the data
    my $location = $blist->get_data_location_for({
        allow_head => 0,
    });
    my $old_value = $location && $self->engine->load_sector( $location );

    my @trans_ids = $self->engine->get_running_txn_ids;

    # If we're the HEAD and there are running txns, then we need to clone this
    # value to the other transactions to preserve Isolation.
    if ( $self->engine->trans_id == 0 ) {
        if ( @trans_ids ) {
            foreach my $other_trans_id ( @trans_ids ) {
                next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 });
                $blist->write_md5({
                    trans_id => $other_trans_id,
                    key      => $args->{key},
                    key_md5  => $args->{key_md5},
                    value    => $old_value->clone,
                });
            }
        }
    }

    my $data;
    if ( @trans_ids ) {
        $blist->mark_deleted( $args );

        if ( $old_value ) {
            #XXX Is this export => 1 actually doing anything?
            $data = $old_value->data({ export => 1 });
            $old_value->free;
        }
    }
    else {
        $data = $blist->delete_md5( $args );
    }

    return $data;
}

sub write_blist_loc {
    my $self = shift;
    my ($loc) = @_;

    my $engine = $self->engine;
    $engine->storage->print_at( $self->offset + $self->base_size,
        pack( $StP{$engine->byte_size}, $loc ),
    );
}

sub get_blist_loc {
    my $self = shift;

    my $e = $self->engine;
    my $blist_loc = $e->storage->read_at( $self->offset + $self->base_size, $e->byte_size );
    return unpack( $StP{$e->byte_size}, $blist_loc );
}

sub get_bucket_list {
    my $self = shift;
    my ($args) = @_;
    $args ||= {};

    # XXX Add in check here for recycling?

    my $engine = $self->engine;

    my $blist_loc = $self->get_blist_loc;

    # There's no index or blist yet
    unless ( $blist_loc ) {
        return unless $args->{create};

        my $blist = DBM::Deep::Sector::File::BucketList->new({
            engine  => $engine,
            key_md5 => $args->{key_md5},
        });

        $self->write_blist_loc( $blist->offset );
#        $engine->storage->print_at( $self->offset + $self->base_size,
#            pack( $StP{$engine->byte_size}, $blist->offset ),
#        );

        return $blist;
    }

    my $sector = $engine->load_sector( $blist_loc )
        or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
    my $i = 0;
    my $last_sector = undef;
    while ( $sector->isa( 'DBM::Deep::Sector::File::Index' ) ) {
        $blist_loc = $sector->get_entry( ord( substr( $args->{key_md5}, $i++, 1 ) ) );
        $last_sector = $sector;
        if ( $blist_loc ) {
            $sector = $engine->load_sector( $blist_loc )
                or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
        }
        else {
            $sector = undef;
            last;
        }
    }

    # This means we went through the Index sector(s) and found an empty slot
    unless ( $sector ) {
        return unless $args->{create};

        DBM::Deep->_throw_error( "No last_sector when attempting to build a new entry" )
            unless $last_sector;

        my $blist = DBM::Deep::Sector::File::BucketList->new({
            engine  => $engine,
            key_md5 => $args->{key_md5},
        });

        $last_sector->set_entry( ord( substr( $args->{key_md5}, $i - 1, 1 ) ) => $blist->offset );

        return $blist;
    }

    $sector->find_md5( $args->{key_md5} );

    # See whether or not we need to reindex the bucketlist
    # Yes, the double-braces are there for a reason. if() doesn't create a
    # redo-able block, so we have to create a bare block within the if() for
    # redo-purposes.
    # Patch and idea submitted by sprout@cpan.org. -RobK, 2008-01-09
    if ( !$sector->has_md5 && $args->{create} && $sector->{idx} == -1 ) {{
        my $redo;

        my $new_index = DBM::Deep::Sector::File::Index->new({
            engine => $engine,
        });

        my %blist_cache;
        #XXX q.v. the comments for this function.
        foreach my $entry ( $sector->chopped_up ) {
            my ($spot, $md5) = @{$entry};
            my $idx = ord( substr( $md5, $i, 1 ) );

            # XXX This is inefficient
            my $blist = $blist_cache{$idx}
                ||= DBM::Deep::Sector::File::BucketList->new({
                    engine => $engine,
                });

            $new_index->set_entry( $idx => $blist->offset );

            my $new_spot = $blist->write_at_next_open( $md5 );
            $engine->reindex_entry( $spot => $new_spot );
        }

        # Handle the new item separately.
        {
            my $idx = ord( substr( $args->{key_md5}, $i, 1 ) );

            # If all the previous blist's items have been thrown into one
            # blist and the new item belongs in there too, we need
            # another index.
            if ( keys %blist_cache == 1 and each %blist_cache == $idx ) {
                ++$i, ++$redo;
            } else {
                my $blist = $blist_cache{$idx}
                    ||= DBM::Deep::Sector::File::BucketList->new({
                        engine => $engine,
                    });
    
                $new_index->set_entry( $idx => $blist->offset );
    
                #XXX THIS IS HACKY!
                $blist->find_md5( $args->{key_md5} );
                $blist->write_md5({
                    key     => $args->{key},
                    key_md5 => $args->{key_md5},
                    value   => DBM::Deep::Sector::File::Null->new({
                        engine => $engine,
                        data   => undef,
                    }),
                });
            }
        }

        if ( $last_sector ) {
            $last_sector->set_entry(
                ord( substr( $args->{key_md5}, $i - 1, 1 ) ),
                $new_index->offset,
            );
        } else {
            $engine->storage->print_at( $self->offset + $self->base_size,
                pack( $StP{$engine->byte_size}, $new_index->offset ),
            );
        }

        $sector->wipe;
        $sector->free;

        if ( $redo ) {
            (undef, $sector) = %blist_cache;
            $last_sector = $new_index;
            redo;
        }

        $sector = $blist_cache{ ord( substr( $args->{key_md5}, $i, 1 ) ) };
        $sector->find_md5( $args->{key_md5} );
    }}

    return $sector;
}

sub get_class_offset {
    my $self = shift;

    my $e = $self->engine;
    return unpack(
        $StP{$e->byte_size},
        $e->storage->read_at(
            $self->offset + $self->base_size + 1 * $e->byte_size, $e->byte_size,
        ),
    );
}

sub get_classname {
    my $self = shift;

    my $class_offset = $self->get_class_offset;

    return unless $class_offset;

    return $self->engine->load_sector( $class_offset )->data;
}

# Look to hoist this method into a ::Reference trait
sub data {
    my $self = shift;
    my ($args) = @_;
    $args ||= {};

    my $engine = $self->engine;
#    if ( !exists $engine->cache->{ $self->offset } ) {
        my $obj = DBM::Deep->new({
            type        => $self->type,
            base_offset => $self->offset,
            staleness   => $self->staleness,
            storage     => $engine->storage,
            engine      => $engine,
        });

#        $engine->cache->{$self->offset} = $obj;
#    }
#    my $obj = $engine->cache->{$self->offset};

    # We're not exporting, so just return.
    unless ( $args->{export} ) {
        if ( $engine->storage->{autobless} ) {
            my $classname = $self->get_classname;
            if ( defined $classname ) {
                bless $obj, $classname;
            }
        }

        return $obj;
    }

    # We shouldn't export if this is still referred to.
    if ( $self->get_refcount > 1 ) {
        return $obj;
    }

    return $obj->export;
}

sub free {
    my $self = shift;

    # We're not ready to be removed yet.
    return if $self->decrement_refcount > 0;

    # Rebless the object into DBM::Deep::Null.
    eval { %{ $self->engine->cache->{ $self->offset } } = (); };
    eval { @{ $self->engine->cache->{ $self->offset } } = (); };
    bless $self->engine->cache->{ $self->offset }, 'DBM::Deep::Null';
    delete $self->engine->cache->{ $self->offset };

    my $blist_loc = $self->get_blist_loc;
    $self->engine->load_sector( $blist_loc )->free if $blist_loc;

    my $class_loc = $self->get_class_offset;
    $self->engine->load_sector( $class_loc )->free if $class_loc;

    $self->SUPER::free();
}

sub increment_refcount {
    my $self = shift;

    my $refcount = $self->get_refcount;

    $refcount++;

    $self->write_refcount( $refcount );

    return $refcount;
}

sub decrement_refcount {
    my $self = shift;

    my $refcount = $self->get_refcount;

    $refcount--;

    $self->write_refcount( $refcount );

    return $refcount;
}

sub get_refcount {
    my $self = shift;

    my $e = $self->engine;
    return unpack(
        $StP{$e->byte_size},
        $e->storage->read_at(
            $self->offset + $self->base_size + 2 * $e->byte_size, $e->byte_size,
        ),
    );
}

sub write_refcount {
    my $self = shift;
    my ($num) = @_;

    my $e = $self->engine;
    $e->storage->print_at(
        $self->offset + $self->base_size + 2 * $e->byte_size,
        pack( $StP{$e->byte_size}, $num ),
    );
}

sub clear {
    my $self = shift;

    my $blist_loc = $self->get_blist_loc or return;

    my $engine = $self->engine;

    # This won't work with autoblessed items.
    if ($engine->get_running_txn_ids) {
        # ~~~ Temporary; the code below this block needs to be modified to
        #     take transactions into account.
        $self->data->_get_self->_clear;
        return;
    }

    my $sector = $engine->load_sector( $blist_loc )
        or DBM::Deep->_throw_error(
           "Cannot read sector at $blist_loc in clear()"
        );

    # Set blist offset to 0
    $engine->storage->print_at( $self->offset + $self->base_size,
        pack( $StP{$engine->byte_size}, 0 ),
    );

    # Free the blist
    $sector->free;

    return;
}

1;
__END__
Commit	Line	Data
2c70efe1	1	package DBM::Deep::Sector::File::Reference;
f0276afb	2
	3	use 5.006_000;
	4
	5	use strict;
	6	use warnings FATAL => 'all';
	7
2c70efe1	8	use base qw( DBM::Deep::Sector::File::Data );
f0276afb	9
5ae752e2	10	my $STALE_SIZE = 2;
	11
	12	# Please refer to the pack() documentation for further information
	13	my %StP = (
	14	1 => 'C', # Unsigned char value (no order needed as it's just one byte)
	15	2 => 'n', # Unsigned short in "network" (big-endian) order
	16	4 => 'N', # Unsigned long in "network" (big-endian) order
	17	8 => 'Q', # Usigned quad (no order specified, presumably machine-dependent)
	18	);
	19
f0276afb	20	sub _init {
	21	my $self = shift;
	22
	23	my $e = $self->engine;
	24
	25	unless ( $self->offset ) {
	26	my $classname = Scalar::Util::blessed( delete $self->{data} );
	27	my $leftover = $self->size - $self->base_size - 3 * $e->byte_size;
	28
	29	my $class_offset = 0;
	30	if ( defined $classname ) {
2c70efe1	31	my $class_sector = DBM::Deep::Sector::File::Scalar->new({
f0276afb	32	engine => $e,
	33	data => $classname,
	34	});
	35	$class_offset = $class_sector->offset;
	36	}
	37
	38	$self->{offset} = $e->_request_data_sector( $self->size );
	39	$e->storage->print_at( $self->offset, $self->type ); # Sector type
	40	# Skip staleness counter
	41	$e->storage->print_at( $self->offset + $self->base_size,
	42	pack( $StP{$e->byte_size}, 0 ), # Index/BList loc
	43	pack( $StP{$e->byte_size}, $class_offset ), # Classname loc
	44	pack( $StP{$e->byte_size}, 1 ), # Initial refcount
	45	chr(0) x $leftover, # Zero-fill the rest
	46	);
	47	}
	48	else {
	49	$self->{type} = $e->storage->read_at( $self->offset, 1 );
	50	}
	51
	52	$self->{staleness} = unpack(
	53	$StP{$STALE_SIZE},
	54	$e->storage->read_at( $self->offset + $e->SIG_SIZE, $STALE_SIZE ),
	55	);
	56
	57	return;
	58	}
	59
f0276afb	60	sub get_data_location_for {
	61	my $self = shift;
	62	my ($args) = @_;
	63
	64	# Assume that the head is not allowed unless otherwise specified.
	65	$args->{allow_head} = 0 unless exists $args->{allow_head};
	66
	67	# Assume we don't create a new blist location unless otherwise specified.
	68	$args->{create} = 0 unless exists $args->{create};
	69
	70	my $blist = $self->get_bucket_list({
	71	key_md5 => $args->{key_md5},
	72	key => $args->{key},
	73	create => $args->{create},
	74	});
	75	return unless $blist && $blist->{found};
	76
	77	# At this point, $blist knows where the md5 is. What it -doesn't- know yet
	78	# is whether or not this transaction has this key. That's part of the next
	79	# function call.
	80	my $location = $blist->get_data_location_for({
	81	allow_head => $args->{allow_head},
	82	}) or return;
	83
	84	return $location;
	85	}
	86
	87	sub get_data_for {
	88	my $self = shift;
	89	my ($args) = @_;
	90
	91	my $location = $self->get_data_location_for( $args )
	92	or return;
	93
d6ecf579	94	return $self->engine->load_sector( $location );
f0276afb	95	}
	96
	97	sub write_data {
	98	my $self = shift;
	99	my ($args) = @_;
	100
	101	my $blist = $self->get_bucket_list({
	102	key_md5 => $args->{key_md5},
	103	key => $args->{key},
	104	create => 1,
	105	}) or DBM::Deep->_throw_error( "How did write_data fail (no blist)?!" );
	106
	107	# Handle any transactional bookkeeping.
	108	if ( $self->engine->trans_id ) {
	109	if ( ! $blist->has_md5 ) {
	110	$blist->mark_deleted({
	111	trans_id => 0,
	112	});
	113	}
	114	}
	115	else {
	116	my @trans_ids = $self->engine->get_running_txn_ids;
	117	if ( $blist->has_md5 ) {
	118	if ( @trans_ids ) {
	119	my $old_value = $blist->get_data_for;
	120	foreach my $other_trans_id ( @trans_ids ) {
	121	next if $blist->get_data_location_for({
	122	trans_id => $other_trans_id,
	123	allow_head => 0,
	124	});
	125	$blist->write_md5({
	126	trans_id => $other_trans_id,
	127	key => $args->{key},
	128	key_md5 => $args->{key_md5},
	129	value => $old_value->clone,
	130	});
	131	}
	132	}
	133	}
	134	else {
	135	if ( @trans_ids ) {
	136	foreach my $other_trans_id ( @trans_ids ) {
	137	#XXX This doesn't seem to possible to ever happen . . .
	138	next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 });
	139	$blist->mark_deleted({
	140	trans_id => $other_trans_id,
	141	});
	142	}
	143	}
	144	}
	145	}
	146
	147	#XXX Is this safe to do transactionally?
	148	# Free the place we're about to write to.
	149	if ( $blist->get_data_location_for({ allow_head => 0 }) ) {
	150	$blist->get_data_for({ allow_head => 0 })->free;
	151	}
	152
	153	$blist->write_md5({
	154	key => $args->{key},
	155	key_md5 => $args->{key_md5},
	156	value => $args->{value},
	157	});
	158	}
159
160	sub delete_key {
161	my $self = shift;
162	my ($args) = @_;
163
c803879b	164	# This can return nothing if we are deleting an entry in a hashref that was
	165	# auto-vivified as part of the delete process. For example:
	166	# my $x = {};
	167	# delete $x->{foo}{bar};
f0276afb	168	my $blist = $self->get_bucket_list({
f0276afb	169	key_md5 => $args->{key_md5},
c803879b	170	}) or return;
f0276afb	171
	172	# Save the location so that we can free the data
	173	my $location = $blist->get_data_location_for({
	174	allow_head => 0,
	175	});
d6ecf579	176	my $old_value = $location && $self->engine->load_sector( $location );
f0276afb	177
	178	my @trans_ids = $self->engine->get_running_txn_ids;
	179
a4d36ff6	180	# If we're the HEAD and there are running txns, then we need to clone this
a4d36ff6	181	# value to the other transactions to preserve Isolation.
f0276afb	182	if ( $self->engine->trans_id == 0 ) {
	183	if ( @trans_ids ) {
	184	foreach my $other_trans_id ( @trans_ids ) {
	185	next if $blist->get_data_location_for({ trans_id => $other_trans_id, allow_head => 0 });
	186	$blist->write_md5({
	187	trans_id => $other_trans_id,
	188	key => $args->{key},
	189	key_md5 => $args->{key_md5},
	190	value => $old_value->clone,
	191	});
	192	}
	193	}
	194	}
	195
	196	my $data;
	197	if ( @trans_ids ) {
	198	$blist->mark_deleted( $args );
	199
	200	if ( $old_value ) {
a4d36ff6	201	#XXX Is this export => 1 actually doing anything?
f0276afb	202	$data = $old_value->data({ export => 1 });
	203	$old_value->free;
	204	}
	205	}
	206	else {
	207	$data = $blist->delete_md5( $args );
	208	}
	209
	210	return $data;
	211	}
	212
d3aaaf5e	213	sub write_blist_loc {
	214	my $self = shift;
	215	my ($loc) = @_;
	216
	217	my $engine = $self->engine;
	218	$engine->storage->print_at( $self->offset + $self->base_size,
	219	pack( $StP{$engine->byte_size}, $loc ),
	220	);
d3aaaf5e	221	}
d3aaaf5e	222
f0276afb	223	sub get_blist_loc {
	224	my $self = shift;
	225
	226	my $e = $self->engine;
	227	my $blist_loc = $e->storage->read_at( $self->offset + $self->base_size, $e->byte_size );
	228	return unpack( $StP{$e->byte_size}, $blist_loc );
	229	}
	230
	231	sub get_bucket_list {
	232	my $self = shift;
	233	my ($args) = @_;
	234	$args \|\|= {};
	235
	236	# XXX Add in check here for recycling?
	237
	238	my $engine = $self->engine;
	239
	240	my $blist_loc = $self->get_blist_loc;
	241
	242	# There's no index or blist yet
	243	unless ( $blist_loc ) {
	244	return unless $args->{create};
	245
2c70efe1	246	my $blist = DBM::Deep::Sector::File::BucketList->new({
f0276afb	247	engine => $engine,
	248	key_md5 => $args->{key_md5},
	249	});
	250
d3aaaf5e	251	$self->write_blist_loc( $blist->offset );
	252	# $engine->storage->print_at( $self->offset + $self->base_size,
	253	# pack( $StP{$engine->byte_size}, $blist->offset ),
	254	# );
f0276afb	255
	256	return $blist;
	257	}
	258
d6ecf579	259	my $sector = $engine->load_sector( $blist_loc )
f0276afb	260	or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
	261	my $i = 0;
	262	my $last_sector = undef;
2c70efe1	263	while ( $sector->isa( 'DBM::Deep::Sector::File::Index' ) ) {
f0276afb	264	$blist_loc = $sector->get_entry( ord( substr( $args->{key_md5}, $i++, 1 ) ) );
	265	$last_sector = $sector;
	266	if ( $blist_loc ) {
d6ecf579	267	$sector = $engine->load_sector( $blist_loc )
f0276afb	268	or DBM::Deep->_throw_error( "Cannot read sector at $blist_loc in get_bucket_list()" );
	269	}
	270	else {
	271	$sector = undef;
	272	last;
	273	}
	274	}
	275
	276	# This means we went through the Index sector(s) and found an empty slot
	277	unless ( $sector ) {
	278	return unless $args->{create};
	279
	280	DBM::Deep->_throw_error( "No last_sector when attempting to build a new entry" )
	281	unless $last_sector;
	282
2c70efe1	283	my $blist = DBM::Deep::Sector::File::BucketList->new({
f0276afb	284	engine => $engine,
	285	key_md5 => $args->{key_md5},
	286	});
	287
	288	$last_sector->set_entry( ord( substr( $args->{key_md5}, $i - 1, 1 ) ) => $blist->offset );
	289
	290	return $blist;
	291	}
	292
	293	$sector->find_md5( $args->{key_md5} );
	294
	295	# See whether or not we need to reindex the bucketlist
cd5303b4	296	# Yes, the double-braces are there for a reason. if() doesn't create a
	297	# redo-able block, so we have to create a bare block within the if() for
	298	# redo-purposes.
	299	# Patch and idea submitted by sprout@cpan.org. -RobK, 2008-01-09
f0276afb	300	if ( !$sector->has_md5 && $args->{create} && $sector->{idx} == -1 ) {{
	301	my $redo;
	302
2c70efe1	303	my $new_index = DBM::Deep::Sector::File::Index->new({
f0276afb	304	engine => $engine,
	305	});
	306
	307	my %blist_cache;
	308	#XXX q.v. the comments for this function.
	309	foreach my $entry ( $sector->chopped_up ) {
	310	my ($spot, $md5) = @{$entry};
	311	my $idx = ord( substr( $md5, $i, 1 ) );
	312
	313	# XXX This is inefficient
	314	my $blist = $blist_cache{$idx}
2c70efe1	315	\|\|= DBM::Deep::Sector::File::BucketList->new({
f0276afb	316	engine => $engine,
	317	});
	318
	319	$new_index->set_entry( $idx => $blist->offset );
	320
	321	my $new_spot = $blist->write_at_next_open( $md5 );
	322	$engine->reindex_entry( $spot => $new_spot );
	323	}
	324
	325	# Handle the new item separately.
	326	{
	327	my $idx = ord( substr( $args->{key_md5}, $i, 1 ) );
	328
	329	# If all the previous blist's items have been thrown into one
	330	# blist and the new item belongs in there too, we need
	331	# another index.
	332	if ( keys %blist_cache == 1 and each %blist_cache == $idx ) {
	333	++$i, ++$redo;
	334	} else {
	335	my $blist = $blist_cache{$idx}
2c70efe1	336	\|\|= DBM::Deep::Sector::File::BucketList->new({
f0276afb	337	engine => $engine,
	338	});
	339
	340	$new_index->set_entry( $idx => $blist->offset );
	341
	342	#XXX THIS IS HACKY!
	343	$blist->find_md5( $args->{key_md5} );
	344	$blist->write_md5({
	345	key => $args->{key},
	346	key_md5 => $args->{key_md5},
2c70efe1	347	value => DBM::Deep::Sector::File::Null->new({
f0276afb	348	engine => $engine,
	349	data => undef,
	350	}),
	351	});
	352	}
f0276afb	353	}
	354
	355	if ( $last_sector ) {
	356	$last_sector->set_entry(
	357	ord( substr( $args->{key_md5}, $i - 1, 1 ) ),
	358	$new_index->offset,
	359	);
	360	} else {
	361	$engine->storage->print_at( $self->offset + $self->base_size,
	362	pack( $StP{$engine->byte_size}, $new_index->offset ),
	363	);
	364	}
	365
d3aaaf5e	366	$sector->wipe;
f0276afb	367	$sector->free;
	368
	369	if ( $redo ) {
	370	(undef, $sector) = %blist_cache;
	371	$last_sector = $new_index;
	372	redo;
	373	}
	374
	375	$sector = $blist_cache{ ord( substr( $args->{key_md5}, $i, 1 ) ) };
	376	$sector->find_md5( $args->{key_md5} );
	377	}}
	378
	379	return $sector;
	380	}
	381
	382	sub get_class_offset {
	383	my $self = shift;
	384
	385	my $e = $self->engine;
	386	return unpack(
	387	$StP{$e->byte_size},
	388	$e->storage->read_at(
	389	$self->offset + $self->base_size + 1 * $e->byte_size, $e->byte_size,
	390	),
	391	);
	392	}
	393
	394	sub get_classname {
	395	my $self = shift;
	396
	397	my $class_offset = $self->get_class_offset;
	398
	399	return unless $class_offset;
	400
d6ecf579	401	return $self->engine->load_sector( $class_offset )->data;
f0276afb	402	}
f0276afb	403
4f034d8f	404	# Look to hoist this method into a ::Reference trait
f0276afb	405	sub data {
	406	my $self = shift;
	407	my ($args) = @_;
	408	$args \|\|= {};
	409
e73f12ce	410	my $engine = $self->engine;
	411	# if ( !exists $engine->cache->{ $self->offset } ) {
	412	my $obj = DBM::Deep->new({
f0276afb	413	type => $self->type,
	414	base_offset => $self->offset,
	415	staleness => $self->staleness,
e73f12ce	416	storage => $engine->storage,
e73f12ce	417	engine => $engine,
f0276afb	418	});
f0276afb	419
e73f12ce	420	# $engine->cache->{$self->offset} = $obj;
	421	# }
	422	# my $obj = $engine->cache->{$self->offset};
	423
	424	# We're not exporting, so just return.
	425	unless ( $args->{export} ) {
	426	if ( $engine->storage->{autobless} ) {
f0276afb	427	my $classname = $self->get_classname;
	428	if ( defined $classname ) {
	429	bless $obj, $classname;
	430	}
	431	}
	432
f0276afb	433	return $obj;
	434	}
	435
	436	# We shouldn't export if this is still referred to.
	437	if ( $self->get_refcount > 1 ) {
	438	return $obj;
	439	}
	440
	441	return $obj->export;
	442	}
	443
	444	sub free {
	445	my $self = shift;
	446
	447	# We're not ready to be removed yet.
4f034d8f	448	return if $self->decrement_refcount > 0;
f0276afb	449
	450	# Rebless the object into DBM::Deep::Null.
	451	eval { %{ $self->engine->cache->{ $self->offset } } = (); };
	452	eval { @{ $self->engine->cache->{ $self->offset } } = (); };
	453	bless $self->engine->cache->{ $self->offset }, 'DBM::Deep::Null';
	454	delete $self->engine->cache->{ $self->offset };
	455
	456	my $blist_loc = $self->get_blist_loc;
d6ecf579	457	$self->engine->load_sector( $blist_loc )->free if $blist_loc;
f0276afb	458
f0276afb	459	my $class_loc = $self->get_class_offset;
d6ecf579	460	$self->engine->load_sector( $class_loc )->free if $class_loc;
f0276afb	461
	462	$self->SUPER::free();
	463	}
	464
	465	sub increment_refcount {
	466	my $self = shift;
	467
	468	my $refcount = $self->get_refcount;
	469
	470	$refcount++;
	471
	472	$self->write_refcount( $refcount );
	473
	474	return $refcount;
	475	}
	476
	477	sub decrement_refcount {
	478	my $self = shift;
	479
	480	my $refcount = $self->get_refcount;
	481
	482	$refcount--;
	483
	484	$self->write_refcount( $refcount );
	485
	486	return $refcount;
	487	}
	488
	489	sub get_refcount {
	490	my $self = shift;
	491
	492	my $e = $self->engine;
	493	return unpack(
	494	$StP{$e->byte_size},
	495	$e->storage->read_at(
	496	$self->offset + $self->base_size + 2 * $e->byte_size, $e->byte_size,
	497	),
	498	);
	499	}
	500
	501	sub write_refcount {
	502	my $self = shift;
	503	my ($num) = @_;
	504
	505	my $e = $self->engine;
	506	$e->storage->print_at(
	507	$self->offset + $self->base_size + 2 * $e->byte_size,
	508	pack( $StP{$e->byte_size}, $num ),
	509	);
	510	}
	511
e73f12ce	512	sub clear {
	513	my $self = shift;
	514
	515	my $blist_loc = $self->get_blist_loc or return;
	516
	517	my $engine = $self->engine;
	518
	519	# This won't work with autoblessed items.
	520	if ($engine->get_running_txn_ids) {
	521	# ~~~ Temporary; the code below this block needs to be modified to
	522	# take transactions into account.
	523	$self->data->_get_self->_clear;
	524	return;
	525	}
	526
	527	my $sector = $engine->load_sector( $blist_loc )
	528	or DBM::Deep->_throw_error(
	529	"Cannot read sector at $blist_loc in clear()"
	530	);
	531
	532	# Set blist offset to 0
	533	$engine->storage->print_at( $self->offset + $self->base_size,
	534	pack( $StP{$engine->byte_size}, 0 ),
	535	);
	536
	537	# Free the blist
	538	$sector->free;
	539
	540	return;
	541	}
	542
f0276afb	543	1;
f0276afb	544	__END__