lib/DBM/Deep.pm

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