lib/DBM/Deep.pm

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