cached singletons for most cases. The external reference issue is starting to come...
[dbsrgits/DBM-Deep.git] / lib / DBM / Deep.pm
CommitLineData
ffed8b01 1package DBM::Deep;
2
b48ae6ec 3use 5.006_000;
460b1067 4
ffed8b01 5use strict;
460b1067 6use warnings;
8b957036 7
ef3cf62e 8our $VERSION = q(1.0005);
86867f3a 9
9a63e1f2 10use Fcntl qw( :flock );
12b96196 11
b48ae6ec 12use Clone ();
ffed8b01 13use Digest::MD5 ();
a8fdabda 14use FileHandle::Fmode ();
ffed8b01 15use Scalar::Util ();
ffed8b01 16
9a63e1f2 17use DBM::Deep::Engine;
460b1067 18use DBM::Deep::File;
95967a5e 19
ef3cf62e 20use overload
21 '""' => sub { overload::StrVal( $_[0] ) },
22 fallback => 1;
23
ffed8b01 24##
25# Setup constants for users to pass to new()
26##
9a63e1f2 27sub TYPE_HASH () { DBM::Deep::Engine->SIG_HASH }
28sub TYPE_ARRAY () { DBM::Deep::Engine->SIG_ARRAY }
ffed8b01 29
9a63e1f2 30# This is used in all the children of this class in their TIE<type> methods.
0ca7ea98 31sub _get_args {
32 my $proto = shift;
33
34 my $args;
35 if (scalar(@_) > 1) {
36 if ( @_ % 2 ) {
37 $proto->_throw_error( "Odd number of parameters to " . (caller(1))[2] );
38 }
39 $args = {@_};
40 }
d0b74c17 41 elsif ( ref $_[0] ) {
4d35d856 42 unless ( eval { local $SIG{'__DIE__'}; %{$_[0]} || 1 } ) {
0ca7ea98 43 $proto->_throw_error( "Not a hashref in args to " . (caller(1))[2] );
44 }
45 $args = $_[0];
46 }
d0b74c17 47 else {
0ca7ea98 48 $args = { file => shift };
49 }
50
51 return $args;
52}
53
ffed8b01 54sub new {
d0b74c17 55 ##
56 # Class constructor method for Perl OO interface.
57 # Calls tie() and returns blessed reference to tied hash or array,
58 # providing a hybrid OO/tie interface.
59 ##
60 my $class = shift;
61 my $args = $class->_get_args( @_ );
62
63 ##
64 # Check if we want a tied hash or array.
65 ##
66 my $self;
67 if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) {
6fe26b29 68 $class = 'DBM::Deep::Array';
69 require DBM::Deep::Array;
d0b74c17 70 tie @$self, $class, %$args;
71 }
72 else {
6fe26b29 73 $class = 'DBM::Deep::Hash';
74 require DBM::Deep::Hash;
d0b74c17 75 tie %$self, $class, %$args;
76 }
ffed8b01 77
d0b74c17 78 return bless $self, $class;
ffed8b01 79}
80
96041a25 81# This initializer is called from the various TIE* methods. new() calls tie(),
82# which allows for a single point of entry.
0795f290 83sub _init {
0795f290 84 my $class = shift;
994ccd8e 85 my ($args) = @_;
0795f290 86
83371fe3 87 $args->{storage} = DBM::Deep::File->new( $args )
88 unless exists $args->{storage};
460b1067 89
90 # locking implicitly enables autoflush
91 if ($args->{locking}) { $args->{autoflush} = 1; }
92
0795f290 93 # These are the defaults to be optionally overridden below
94 my $self = bless {
95967a5e 95 type => TYPE_HASH,
e06824f8 96 base_offset => undef,
9a63e1f2 97 staleness => undef,
359a01ac 98
83371fe3 99 storage => undef,
9a63e1f2 100 engine => undef,
0795f290 101 }, $class;
9a63e1f2 102
103 $args->{engine} = DBM::Deep::Engine->new( { %{$args}, obj => $self } )
104 unless exists $args->{engine};
8db25060 105
fde3db1a 106 # Grab the parameters we want to use
0795f290 107 foreach my $param ( keys %$self ) {
108 next unless exists $args->{$param};
3e9498a1 109 $self->{$param} = $args->{$param};
ffed8b01 110 }
d0b74c17 111
9a63e1f2 112 eval {
113 local $SIG{'__DIE__'};
0795f290 114
9a63e1f2 115 $self->lock;
116 $self->_engine->setup_fh( $self );
117 $self->_storage->set_inode;
118 $self->unlock;
119 }; if ( $@ ) {
120 my $e = $@;
121 eval { local $SIG{'__DIE__'}; $self->unlock; };
122 die $e;
123 }
359a01ac 124
0795f290 125 return $self;
ffed8b01 126}
127
ffed8b01 128sub TIEHASH {
6fe26b29 129 shift;
130 require DBM::Deep::Hash;
131 return DBM::Deep::Hash->TIEHASH( @_ );
ffed8b01 132}
133
134sub TIEARRAY {
6fe26b29 135 shift;
136 require DBM::Deep::Array;
137 return DBM::Deep::Array->TIEARRAY( @_ );
ffed8b01 138}
139
ffed8b01 140sub lock {
994ccd8e 141 my $self = shift->_get_self;
83371fe3 142 return $self->_storage->lock( $self, @_ );
ffed8b01 143}
144
145sub unlock {
994ccd8e 146 my $self = shift->_get_self;
83371fe3 147 return $self->_storage->unlock( $self, @_ );
ffed8b01 148}
149
906c8e01 150sub _copy_value {
151 my $self = shift->_get_self;
152 my ($spot, $value) = @_;
153
154 if ( !ref $value ) {
155 ${$spot} = $value;
156 }
157 elsif ( eval { local $SIG{__DIE__}; $value->isa( 'DBM::Deep' ) } ) {
f9c33187 158 ${$spot} = $value->_repr;
906c8e01 159 $value->_copy_node( ${$spot} );
160 }
161 else {
162 my $r = Scalar::Util::reftype( $value );
163 my $c = Scalar::Util::blessed( $value );
164 if ( $r eq 'ARRAY' ) {
165 ${$spot} = [ @{$value} ];
166 }
167 else {
168 ${$spot} = { %{$value} };
169 }
95bbd935 170 ${$spot} = bless ${$spot}, $c
906c8e01 171 if defined $c;
172 }
173
174 return 1;
175}
176
9a63e1f2 177#sub _copy_node {
178# die "Must be implemented in a child class\n";
179#}
180#
181#sub _repr {
182# die "Must be implemented in a child class\n";
183#}
ffed8b01 184
185sub export {
d0b74c17 186 ##
187 # Recursively export into standard Perl hashes and arrays.
188 ##
994ccd8e 189 my $self = shift->_get_self;
d0b74c17 190
f9c33187 191 my $temp = $self->_repr;
d0b74c17 192
193 $self->lock();
194 $self->_copy_node( $temp );
195 $self->unlock();
196
9a63e1f2 197 my $classname = $self->_engine->get_classname( $self );
198 if ( defined $classname ) {
199 bless $temp, $classname;
68f943b3 200 }
201
d0b74c17 202 return $temp;
ffed8b01 203}
204
205sub import {
d0b74c17 206 ##
207 # Recursively import Perl hash/array structure
208 ##
d0b74c17 209 if (!ref($_[0])) { return; } # Perl calls import() on use -- ignore
210
994ccd8e 211 my $self = shift->_get_self;
212 my ($struct) = @_;
d0b74c17 213
c9cec40e 214 # struct is not a reference, so just import based on our type
d0b74c17 215 if (!ref($struct)) {
f9c33187 216 $struct = $self->_repr( @_ );
d0b74c17 217 }
218
12b96196 219 #XXX This isn't the best solution. Better would be to use Data::Walker,
220 #XXX but that's a lot more thinking than I want to do right now.
7a960a12 221 eval {
9a63e1f2 222 local $SIG{'__DIE__'};
b48ae6ec 223 $self->_import( Clone::clone( $struct ) );
9a63e1f2 224 }; if ( my $e = $@ ) {
9a63e1f2 225 die $e;
7a960a12 226 }
227
228 return 1;
ffed8b01 229}
230
13ff93d5 231#XXX Need to keep track of who has a fh to this file in order to
232#XXX close them all prior to optimize on Win32/cygwin
ffed8b01 233sub optimize {
d0b74c17 234 ##
235 # Rebuild entire database into new file, then move
236 # it back on top of original.
237 ##
994ccd8e 238 my $self = shift->_get_self;
cc4bef86 239
240#XXX Need to create a new test for this
83371fe3 241# if ($self->_storage->{links} > 1) {
1400a48e 242# $self->_throw_error("Cannot optimize: reference count is greater than 1");
d0b74c17 243# }
244
7a960a12 245 #XXX Do we have to lock the tempfile?
246
d0b74c17 247 my $db_temp = DBM::Deep->new(
83371fe3 248 file => $self->_storage->{file} . '.tmp',
9a63e1f2 249 type => $self->_type,
250
251 # Bring over all the parameters that we need to bring over
3300d0b3 252 ( map { $_ => $self->_engine->$_ } qw(
253 byte_size max_buckets data_sector_size num_txns
254 )),
d0b74c17 255 );
d0b74c17 256
257 $self->lock();
90a80a23 258 $self->_engine->clear_cache;
d0b74c17 259 $self->_copy_node( $db_temp );
260 undef $db_temp;
261
262 ##
263 # Attempt to copy user, group and permissions over to new file
264 ##
265 my @stats = stat($self->_fh);
266 my $perms = $stats[2] & 07777;
267 my $uid = $stats[4];
268 my $gid = $stats[5];
83371fe3 269 chown( $uid, $gid, $self->_storage->{file} . '.tmp' );
270 chmod( $perms, $self->_storage->{file} . '.tmp' );
d0b74c17 271
ffed8b01 272 # q.v. perlport for more information on this variable
90f93b43 273 if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) {
d0b74c17 274 ##
275 # Potential race condition when optmizing on Win32 with locking.
276 # The Windows filesystem requires that the filehandle be closed
277 # before it is overwritten with rename(). This could be redone
278 # with a soft copy.
279 ##
280 $self->unlock();
83371fe3 281 $self->_storage->close;
d0b74c17 282 }
283
83371fe3 284 if (!rename $self->_storage->{file} . '.tmp', $self->_storage->{file}) {
285 unlink $self->_storage->{file} . '.tmp';
d0b74c17 286 $self->unlock();
1400a48e 287 $self->_throw_error("Optimize failed: Cannot copy temp file over original: $!");
d0b74c17 288 }
289
290 $self->unlock();
83371fe3 291 $self->_storage->close;
9a63e1f2 292
83371fe3 293 $self->_storage->open;
9a63e1f2 294 $self->lock();
72e315ac 295 $self->_engine->setup_fh( $self );
9a63e1f2 296 $self->unlock();
70b55428 297
d0b74c17 298 return 1;
ffed8b01 299}
300
301sub clone {
d0b74c17 302 ##
303 # Make copy of object and return
304 ##
994ccd8e 305 my $self = shift->_get_self;
d0b74c17 306
307 return DBM::Deep->new(
c3aafc14 308 type => $self->_type,
d0b74c17 309 base_offset => $self->_base_offset,
9a63e1f2 310 staleness => $self->_staleness,
83371fe3 311 storage => $self->_storage,
9a63e1f2 312 engine => $self->_engine,
d0b74c17 313 );
ffed8b01 314}
315
9a63e1f2 316#XXX Migrate this to the engine, where it really belongs and go through some
317# API - stop poking in the innards of someone else..
ffed8b01 318{
319 my %is_legal_filter = map {
320 $_ => ~~1,
321 } qw(
322 store_key store_value
323 fetch_key fetch_value
324 );
325
326 sub set_filter {
994ccd8e 327 my $self = shift->_get_self;
328 my $type = lc shift;
329 my $func = shift;
d0b74c17 330
ffed8b01 331 if ( $is_legal_filter{$type} ) {
83371fe3 332 $self->_storage->{"filter_$type"} = $func;
ffed8b01 333 return 1;
334 }
335
336 return;
337 }
9f83dc31 338
339 sub filter_store_key { $_[0]->set_filter( store_key => $_[1] ); }
340 sub filter_store_value { $_[0]->set_filter( store_value => $_[1] ); }
341 sub filter_fetch_key { $_[0]->set_filter( fetch_key => $_[1] ); }
342 sub filter_fetch_value { $_[0]->set_filter( fetch_value => $_[1] ); }
ffed8b01 343}
344
fee0243f 345sub begin_work {
346 my $self = shift->_get_self;
9a63e1f2 347 return $self->_engine->begin_work( $self, @_ );
fee0243f 348}
349
350sub rollback {
351 my $self = shift->_get_self;
9a63e1f2 352 return $self->_engine->rollback( $self, @_ );
fee0243f 353}
354
359a01ac 355sub commit {
356 my $self = shift->_get_self;
9a63e1f2 357 return $self->_engine->commit( $self, @_ );
359a01ac 358}
fee0243f 359
ffed8b01 360##
361# Accessor methods
362##
363
72e315ac 364sub _engine {
365 my $self = $_[0]->_get_self;
366 return $self->{engine};
367}
368
83371fe3 369sub _storage {
2ac02042 370 my $self = $_[0]->_get_self;
83371fe3 371 return $self->{storage};
ffed8b01 372}
373
4d35d856 374sub _type {
2ac02042 375 my $self = $_[0]->_get_self;
d0b74c17 376 return $self->{type};
ffed8b01 377}
378
4d35d856 379sub _base_offset {
2ac02042 380 my $self = $_[0]->_get_self;
d0b74c17 381 return $self->{base_offset};
ffed8b01 382}
383
9a63e1f2 384sub _staleness {
385 my $self = $_[0]->_get_self;
386 return $self->{staleness};
387}
388
994ccd8e 389sub _fh {
994ccd8e 390 my $self = $_[0]->_get_self;
83371fe3 391 return $self->_storage->{fh};
994ccd8e 392}
393
ffed8b01 394##
395# Utility methods
396##
397
261d1296 398sub _throw_error {
a34e9b3f 399 my $n = 0;
400 while( 1 ) {
401 my @caller = caller( ++$n );
402 next if $caller[0] =~ m/^DBM::Deep/;
403
404 die "DBM::Deep: $_[1] at $0 line $caller[2]\n";
a34e9b3f 405 }
ffed8b01 406}
407
ffed8b01 408sub STORE {
d0b74c17 409 ##
410 # Store single hash key/value or array element in database.
411 ##
412 my $self = shift->_get_self;
9a63e1f2 413 my ($key, $value) = @_;
81d3d316 414
a8fdabda 415 if ( !FileHandle::Fmode::is_W( $self->_fh ) ) {
acd4faf2 416 $self->_throw_error( 'Cannot write to a readonly filehandle' );
417 }
d0b74c17 418
419 ##
420 # Request exclusive lock for writing
421 ##
422 $self->lock( LOCK_EX );
423
0cb639bd 424 # User may be storing a complex value, in which case we do not want it run
425 # through the filtering system.
83371fe3 426 if ( !ref($value) && $self->_storage->{filter_store_value} ) {
427 $value = $self->_storage->{filter_store_value}->( $value );
d0b74c17 428 }
429
9a63e1f2 430 $self->_engine->write_value( $self, $key, $value);
d0b74c17 431
432 $self->unlock();
433
86867f3a 434 return 1;
ffed8b01 435}
436
437sub FETCH {
d0b74c17 438 ##
439 # Fetch single value or element given plain key or array index
440 ##
cb79ec85 441 my $self = shift->_get_self;
9a63e1f2 442 my ($key) = @_;
ffed8b01 443
d0b74c17 444 ##
445 # Request shared lock for reading
446 ##
447 $self->lock( LOCK_SH );
448
9a63e1f2 449 my $result = $self->_engine->read_value( $self, $key);
d0b74c17 450
451 $self->unlock();
452
a86430bd 453 # Filters only apply to scalar values, so the ref check is making
454 # sure the fetched bucket is a scalar, not a child hash or array.
83371fe3 455 return ($result && !ref($result) && $self->_storage->{filter_fetch_value})
456 ? $self->_storage->{filter_fetch_value}->($result)
cb79ec85 457 : $result;
ffed8b01 458}
459
460sub DELETE {
d0b74c17 461 ##
462 # Delete single key/value pair or element given plain key or array index
463 ##
a97c8f67 464 my $self = shift->_get_self;
9a63e1f2 465 my ($key) = @_;
d0b74c17 466
a8fdabda 467 if ( !FileHandle::Fmode::is_W( $self->_fh ) ) {
a86430bd 468 $self->_throw_error( 'Cannot write to a readonly filehandle' );
469 }
d0b74c17 470
471 ##
472 # Request exclusive lock for writing
473 ##
474 $self->lock( LOCK_EX );
475
d0b74c17 476 ##
477 # Delete bucket
478 ##
9a63e1f2 479 my $value = $self->_engine->delete_key( $self, $key);
a86430bd 480
83371fe3 481 if (defined $value && !ref($value) && $self->_storage->{filter_fetch_value}) {
482 $value = $self->_storage->{filter_fetch_value}->($value);
3b6a5056 483 }
484
d0b74c17 485 $self->unlock();
486
487 return $value;
ffed8b01 488}
489
490sub EXISTS {
d0b74c17 491 ##
492 # Check if a single key or element exists given plain key or array index
493 ##
a97c8f67 494 my $self = shift->_get_self;
495 my ($key) = @_;
d0b74c17 496
d0b74c17 497 ##
498 # Request shared lock for reading
499 ##
500 $self->lock( LOCK_SH );
501
9a63e1f2 502 my $result = $self->_engine->key_exists( $self, $key );
d0b74c17 503
504 $self->unlock();
505
506 return $result;
ffed8b01 507}
508
509sub CLEAR {
d0b74c17 510 ##
511 # Clear all keys from hash, or all elements from array.
512 ##
a97c8f67 513 my $self = shift->_get_self;
ffed8b01 514
a8fdabda 515 if ( !FileHandle::Fmode::is_W( $self->_fh ) ) {
a86430bd 516 $self->_throw_error( 'Cannot write to a readonly filehandle' );
517 }
518
d0b74c17 519 ##
520 # Request exclusive lock for writing
521 ##
522 $self->lock( LOCK_EX );
523
9a63e1f2 524 #XXX Rewrite this dreck to do it in the engine as a tight loop vs.
525 # iterating over keys - such a WASTE - is this required for transactional
526 # clearning?! Surely that can be detected in the engine ...
f9a320bb 527 if ( $self->_type eq TYPE_HASH ) {
528 my $key = $self->first_key;
529 while ( $key ) {
83c43bb5 530 # Retrieve the key before deleting because we depend on next_key
f9a320bb 531 my $next_key = $self->next_key( $key );
9a63e1f2 532 $self->_engine->delete_key( $self, $key, $key );
f9a320bb 533 $key = $next_key;
534 }
535 }
536 else {
537 my $size = $self->FETCHSIZE;
c3aafc14 538 for my $key ( 0 .. $size - 1 ) {
9a63e1f2 539 $self->_engine->delete_key( $self, $key, $key );
f9a320bb 540 }
541 $self->STORESIZE( 0 );
542 }
d0b74c17 543
544 $self->unlock();
545
546 return 1;
ffed8b01 547}
548
ffed8b01 549##
550# Public method aliases
551##
7f441181 552sub put { (shift)->STORE( @_ ) }
553sub store { (shift)->STORE( @_ ) }
554sub get { (shift)->FETCH( @_ ) }
555sub fetch { (shift)->FETCH( @_ ) }
baa27ab6 556sub delete { (shift)->DELETE( @_ ) }
557sub exists { (shift)->EXISTS( @_ ) }
558sub clear { (shift)->CLEAR( @_ ) }
ffed8b01 559
0700305e 560sub _dump_file {shift->_get_self->_engine->_dump_file;}
9f83dc31 561
ffed8b01 5621;
ffed8b01 563__END__