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