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

package DBM::Deep::Engine::Sector::Reference;

use 5.006_000;

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

use Scalar::Util ();

use DBM::Deep::Null;

use DBM::Deep::Engine::Sector::Data;
our @ISA = qw( DBM::Deep::Engine::Sector::Data );

sub _init {
    my $self = shift;

    my $e = $self->engine;

    unless ( $self->offset ) {
        $self->{offset} = $e->_request_data_sector( $self->size );

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

        $self->write( 0, $self->type );
        $self->write( $self->base_size, 
            pack( $e->StP($e->byte_size), 0 )             # Index/BList loc
          . pack( $e->StP($e->byte_size), $class_offset ) # Classname loc
          . pack( $e->StP($e->byte_size), 1 )             # Initial refcount
        );
    }
    else {
        $self->{type} = $self->read( 0, $e->SIG_SIZE );
    }

    $self->{staleness} = unpack(
        $e->StP($DBM::Deep::Engine::STALE_SIZE),
        $self->read( $e->SIG_SIZE, $DBM::Deep::Engine::STALE_SIZE ),
    );

    return;
}

sub staleness { $_[0]{staleness} }

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) = @_;

    # XXX What should happen if this fails?
    my $blist = $self->get_bucket_list({
        key_md5 => $args->{key_md5},
    }) or DBM::Deep->_throw_error( "How did delete_key fail (no blist)?!" );

    # 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 ) {
            $data = $old_value->data({ export => 1 });
            $old_value->free;
        }
    }
    else {
        $data = $blist->delete_md5( $args );
    }

    return $data;
}

sub get_blist_loc {
    my $self = shift;

    my $e = $self->engine;
    return unpack(
        $e->StP($e->byte_size),
        $self->read( $self->base_size, $e->byte_size ),
    );
}

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::Engine::Sector::BucketList->new({
            engine  => $engine,
            key_md5 => $args->{key_md5},
        });

        $self->write( $self->base_size, pack( $engine->StP($engine->byte_size), $blist->offset ) );

        return $blist;
    }

    my $sector = $engine->_load_sector( $blist_loc )
        or DBM::Deep->_throw_error( "1: Cannot read sector at $blist_loc in get_bucket_list()" );
    my $i = 0;
    my $last_sector = undef;
    while ( $sector->isa( 'DBM::Deep::Engine::Sector::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( "2: 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::Engine::Sector::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::Engine::Sector::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::Engine::Sector::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::Engine::Sector::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::Engine::Sector::Null->new({
                        engine => $engine,
                        data   => undef,
                    }),
                });
            }

#XXX Why is this code here? -RobK, 2008-06-15
#            my $blist = $blist_cache{$idx}
#                ||= DBM::Deep::Engine::Sector::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::Engine::Sector::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 {
            $self->write( $self->base_size, pack( $engine->StP($engine->byte_size), $new_index->offset ) );
        }

        $sector->clear;
        $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(
        $e->StP($e->byte_size),
        $self->read(
            $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;
}

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

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

        if ( $self->engine->storage->{autobless} ) {
            my $classname = $self->get_classname;
            if ( defined $classname ) {
                bless $obj, $classname;
            }
        }

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

    # We're not exporting, so just return.
    unless ( $args->{export} ) {
        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.
    if ( $self->decrement_refcount > 0 ) {
        return;
    }

    # 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(
        $e->StP($e->byte_size),
        $self->read(
            $self->base_size + 2 * $e->byte_size,
            $e->byte_size,
        ),
    );
}

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

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


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