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