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