lib/DBM/Deep.pm

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