X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBM%2FDeep.pm;h=94c296faf73cdfe7ec15b9afc79161aa9f3f364b;hb=a4d36ff61c367864cdf95523dd9771b01773930c;hp=f5ecd688f77f121aca7a1db6edcd8147cdd8eed5;hpb=807f63a7218ff60795f39942940df83687eeeb77;p=dbsrgits%2FDBM-Deep.git diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm index f5ecd68..94c296f 100644 --- a/lib/DBM/Deep.pm +++ b/lib/DBM/Deep.pm @@ -3,23 +3,25 @@ package DBM::Deep; use 5.006_000; use strict; -use warnings; +use warnings FATAL => 'all'; -our $VERSION = q(1.0002); +our $VERSION = q(1.0015); -use Fcntl qw( :flock ); - -use Clone (); -use Digest::MD5 (); -use FileHandle::Fmode (); use Scalar::Util (); -use DBM::Deep::Engine; -use DBM::Deep::File; +use DBM::Deep::Engine::DBI (); +use DBM::Deep::Engine::File (); + +use DBM::Deep::SQL::Util; +use DBM::Deep::SQL::Array; +use DBM::Deep::SQL::Hash; + +use overload + '""' => sub { overload::StrVal( $_[0] ) }, + fallback => 1; + +use constant DEBUG => 0; -## -# Setup constants for users to pass to new() -## sub TYPE_HASH () { DBM::Deep::Engine->SIG_HASH } sub TYPE_ARRAY () { DBM::Deep::Engine->SIG_ARRAY } @@ -47,19 +49,81 @@ sub _get_args { return $args; } +# Class constructor method for Perl OO interface. +# Calls tie() and returns blessed reference to tied hash or array, +# providing a hybrid OO/tie interface. sub new { - ## - # Class constructor method for Perl OO interface. - # Calls tie() and returns blessed reference to tied hash or array, - # providing a hybrid OO/tie interface. - ## my $class = shift; my $args = $class->_get_args( @_ ); + my $self; + +=pod + if (exists $args->{dbi}) { + eval { + require DBIx::Abstract; + }; if ( $@ ) { + __PACKAGE__->_throw_error('DBIx::Abstract not installed. You cannot use the SQL mode.'); + } + unless (UNIVERSAL::isa($args->{dbi}, 'DBIx::Abstract')) { + $args->{dbi} = DBIx::Abstract->connect($args->{dbi}); + } + + if (defined $args->{id}) { + unless ($args->{id} =~ /^\d+$/ && $args->{id} > 0) { + __PACKAGE__->_throw_error('Invalid SQL record id'); + } + my $util = {dbi => $args->{dbi}}; + bless $util, 'DBM::Deep::SQL::Util'; + my $q = $util->_select( + table => 'rec_item', + fields => 'item_type', + where => {id => $args->{id}}, + ); + if ($q->[0]->[0] eq 'array') { + $args->{type} = TYPE_ARRAY; + } + elsif ($q->[0]->[0] eq 'hash') { + $args->{type} = TYPE_HASH; + } + else { + DBM::Deep->_throw_error('Unknown SQL record id'); + } + } + else { + my $util = {dbi => $args->{dbi}}; + bless $util, 'DBM::Deep::SQL::Util'; + if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) { + $args->{id} = $util->_create('array'); + } + else { + $args->{id} = $util->_create('hash'); + } + } + + if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) { + $class = 'DBM::Deep::SQL::Array'; + require DBM::Deep::SQL::Array; + tie @$self, $class, %$args; + if ($args->{prefetch}) { + (tied(@$self))->_prefetch(); + } + return bless $self, $class; + } + else { + $class = 'DBM::Deep::SQL::Hash'; + require DBM::Deep::SQL::Hash; + tie %$self, $class, %$args; + if ($args->{prefetch}) { + (tied(%$self))->_prefetch(); + } + return bless $self, $class; + } + } +=cut ## # Check if we want a tied hash or array. ## - my $self; if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) { $class = 'DBM::Deep::Array'; require DBM::Deep::Array; @@ -80,9 +144,6 @@ sub _init { my $class = shift; my ($args) = @_; - $args->{storage} = DBM::Deep::File->new( $args ) - unless exists $args->{storage}; - # locking implicitly enables autoflush if ($args->{locking}) { $args->{autoflush} = 1; } @@ -91,13 +152,19 @@ sub _init { type => TYPE_HASH, base_offset => undef, staleness => undef, - - storage => undef, engine => undef, }, $class; - $args->{engine} = DBM::Deep::Engine->new( { %{$args}, obj => $self } ) - unless exists $args->{engine}; + unless ( exists $args->{engine} ) { + my $class = exists $args->{dbi} + ? 'DBM::Deep::Engine::DBI' + : 'DBM::Deep::Engine::File'; + + $args->{engine} = $class->new({ + %{$args}, + obj => $self, + }); + } # Grab the parameters we want to use foreach my $param ( keys %$self ) { @@ -106,16 +173,15 @@ sub _init { } eval { - local $SIG{'__DIE__'}; + local $SIG{'__DIE__'}; - $self->lock; - $self->_engine->setup_fh( $self ); - $self->_storage->set_inode; - $self->unlock; + $self->lock_exclusive; + $self->_engine->setup( $self ); + $self->unlock; }; if ( $@ ) { - my $e = $@; - eval { local $SIG{'__DIE__'}; $self->unlock; }; - die $e; + my $e = $@; + eval { local $SIG{'__DIE__'}; $self->unlock; }; + die $e; } return $self; @@ -133,14 +199,19 @@ sub TIEARRAY { return DBM::Deep::Array->TIEARRAY( @_ ); } -sub lock { +sub lock_exclusive { my $self = shift->_get_self; - return $self->_storage->lock( $self, @_ ); + return $self->_engine->lock_exclusive( $self, @_ ); +} +*lock = \&lock_exclusive; +sub lock_shared { + my $self = shift->_get_self; + return $self->_engine->lock_shared( $self, @_ ); } sub unlock { my $self = shift->_get_self; - return $self->_storage->unlock( $self, @_ ); + return $self->_engine->unlock( $self, @_ ); } sub _copy_value { @@ -150,21 +221,36 @@ sub _copy_value { if ( !ref $value ) { ${$spot} = $value; } - elsif ( eval { local $SIG{__DIE__}; $value->isa( 'DBM::Deep' ) } ) { - ${$spot} = $value->_repr; - $value->_copy_node( ${$spot} ); - } else { my $r = Scalar::Util::reftype( $value ); - my $c = Scalar::Util::blessed( $value ); + my $tied; if ( $r eq 'ARRAY' ) { - ${$spot} = [ @{$value} ]; + $tied = tied(@$value); + } + elsif ( $r eq 'HASH' ) { + $tied = tied(%$value); + } + else { + __PACKAGE__->_throw_error( "Unknown type for '$value'" ); + } + + if ( eval { local $SIG{__DIE__}; $tied->isa( __PACKAGE__ ) } ) { + ${$spot} = $tied->_repr; + $tied->_copy_node( ${$spot} ); } else { - ${$spot} = { %{$value} }; + if ( $r eq 'ARRAY' ) { + ${$spot} = [ @{$value} ]; + } + else { + ${$spot} = { %{$value} }; + } + } + + my $c = Scalar::Util::blessed( $value ); + if ( defined $c && !$c->isa( __PACKAGE__ ) ) { + ${$spot} = bless ${$spot}, $c } - ${$spot} = bless ${$spot}, $c - if defined $c; } return 1; @@ -179,16 +265,13 @@ sub _copy_value { #} sub export { - ## - # Recursively export into standard Perl hashes and arrays. - ## my $self = shift->_get_self; my $temp = $self->_repr; - $self->lock(); + $self->lock_exclusive; $self->_copy_node( $temp ); - $self->unlock(); + $self->unlock; my $classname = $self->_engine->get_classname( $self ); if ( defined $classname ) { @@ -198,71 +281,127 @@ sub export { return $temp; } +sub _check_legality { + my $self = shift; + my ($val) = @_; + + my $r = Scalar::Util::reftype( $val ); + + return $r if !defined $r || '' eq $r; + return $r if 'HASH' eq $r; + return $r if 'ARRAY' eq $r; + + __PACKAGE__->_throw_error( + "Storage of references of type '$r' is not supported." + ); +} + sub import { - ## - # Recursively import Perl hash/array structure - ## - if (!ref($_[0])) { return; } # Perl calls import() on use -- ignore + return if !ref $_[0]; # Perl calls import() on use -- ignore my $self = shift->_get_self; my ($struct) = @_; - # struct is not a reference, so just import based on our type - if (!ref($struct)) { - $struct = $self->_repr( @_ ); + my $type = $self->_check_legality( $struct ); + if ( !$type ) { + __PACKAGE__->_throw_error( "Cannot import a scalar" ); } - #XXX This isn't the best solution. Better would be to use Data::Walker, - #XXX but that's a lot more thinking than I want to do right now. - eval { - local $SIG{'__DIE__'}; - $self->_import( Clone::clone( $struct ) ); - }; if ( my $e = $@ ) { - die $e; + if ( substr( $type, 0, 1 ) ne $self->_type ) { + __PACKAGE__->_throw_error( + "Cannot import " . ('HASH' eq $type ? 'a hash' : 'an array') + . " into " . ('HASH' eq $type ? 'an array' : 'a hash') + ); } + my %seen; + my $recurse; + $recurse = sub { + my ($db, $val) = @_; + + my $obj = 'HASH' eq Scalar::Util::reftype( $db ) ? tied(%$db) : tied(@$db); + $obj ||= $db; + + my $r = $self->_check_legality( $val ); + if ( 'HASH' eq $r ) { + while ( my ($k, $v) = each %$val ) { + my $r = $self->_check_legality( $v ); + if ( $r ) { + my $temp = 'HASH' eq $r ? {} : []; + if ( my $c = Scalar::Util::blessed( $v ) ) { + bless $temp, $c; + } + $obj->put( $k, $temp ); + $recurse->( $temp, $v ); + } + else { + $obj->put( $k, $v ); + } + } + } + elsif ( 'ARRAY' eq $r ) { + foreach my $k ( 0 .. $#$val ) { + my $v = $val->[$k]; + my $r = $self->_check_legality( $v ); + if ( $r ) { + my $temp = 'HASH' eq $r ? {} : []; + if ( my $c = Scalar::Util::blessed( $v ) ) { + bless $temp, $c; + } + $obj->put( $k, $temp ); + $recurse->( $temp, $v ); + } + else { + $obj->put( $k, $v ); + } + } + } + }; + $recurse->( $self, $struct ); + return 1; } #XXX Need to keep track of who has a fh to this file in order to #XXX close them all prior to optimize on Win32/cygwin +# Rebuild entire database into new file, then move +# it back on top of original. sub optimize { - ## - # Rebuild entire database into new file, then move - # it back on top of original. - ## my $self = shift->_get_self; + # Optimizing is only something we need to do when we're working with our + # own file format. Otherwise, let the other guy do the optimizations. + return unless $self->_engine->isa( 'DBM::Deep::Engine::File' ); + #XXX Need to create a new test for this -# if ($self->_storage->{links} > 1) { +# if ($self->_engine->storage->{links} > 1) { # $self->_throw_error("Cannot optimize: reference count is greater than 1"); # } #XXX Do we have to lock the tempfile? - my $db_temp = DBM::Deep->new( - file => $self->_storage->{file} . '.tmp', + #XXX Should we use tempfile() here instead of a hard-coded name? + my $temp_filename = $self->_engine->storage->{file} . '.tmp'; + my $db_temp = __PACKAGE__->new( + file => $temp_filename, type => $self->_type, # Bring over all the parameters that we need to bring over - num_txns => $self->_engine->num_txns, - byte_size => $self->_engine->byte_size, - max_buckets => $self->_engine->max_buckets, + ( map { $_ => $self->_engine->$_ } qw( + byte_size max_buckets data_sector_size num_txns + )), ); - $self->lock(); + $self->lock_exclusive; + $self->_engine->clear_cache; $self->_copy_node( $db_temp ); + $db_temp->_engine->storage->close; undef $db_temp; ## # Attempt to copy user, group and permissions over to new file ## - my @stats = stat($self->_fh); - my $perms = $stats[2] & 07777; - my $uid = $stats[4]; - my $gid = $stats[5]; - chown( $uid, $gid, $self->_storage->{file} . '.tmp' ); - chmod( $perms, $self->_storage->{file} . '.tmp' ); + $self->_engine->storage->copy_stats( $temp_filename ); # q.v. perlport for more information on this variable if ( $^O eq 'MSWin32' || $^O eq 'cygwin' ) { @@ -272,23 +411,23 @@ sub optimize { # before it is overwritten with rename(). This could be redone # with a soft copy. ## - $self->unlock(); - $self->_storage->close; + $self->unlock; + $self->_engine->storage->close; } - if (!rename $self->_storage->{file} . '.tmp', $self->_storage->{file}) { - unlink $self->_storage->{file} . '.tmp'; - $self->unlock(); + if (!rename $temp_filename, $self->_engine->storage->{file}) { + unlink $temp_filename; + $self->unlock; $self->_throw_error("Optimize failed: Cannot copy temp file over original: $!"); } - $self->unlock(); - $self->_storage->close; + $self->unlock; + $self->_engine->storage->close; - $self->_storage->open; - $self->lock(); - $self->_engine->setup_fh( $self ); - $self->unlock(); + $self->_engine->storage->open; + $self->lock_exclusive; + $self->_engine->setup( $self ); + $self->unlock; return 1; } @@ -299,11 +438,10 @@ sub clone { ## my $self = shift->_get_self; - return DBM::Deep->new( + return __PACKAGE__->new( type => $self->_type, base_offset => $self->_base_offset, staleness => $self->_staleness, - storage => $self->_storage, engine => $self->_engine, ); } @@ -319,51 +457,60 @@ sub clone { ); sub set_filter { - ## - # Setup filter function for storing or fetching the key or value - ## my $self = shift->_get_self; my $type = lc shift; my $func = shift; if ( $is_legal_filter{$type} ) { - $self->_storage->{"filter_$type"} = $func; + $self->_engine->storage->{"filter_$type"} = $func; return 1; } return; } + + sub filter_store_key { $_[0]->set_filter( store_key => $_[1] ); } + sub filter_store_value { $_[0]->set_filter( store_value => $_[1] ); } + sub filter_fetch_key { $_[0]->set_filter( fetch_key => $_[1] ); } + sub filter_fetch_value { $_[0]->set_filter( fetch_value => $_[1] ); } } sub begin_work { my $self = shift->_get_self; - return $self->_engine->begin_work( $self, @_ ); + $self->lock_exclusive; + my $rv = eval { $self->_engine->begin_work( $self, @_ ) }; + my $e = $@; + $self->unlock; + die $e if $e; + return $rv; } sub rollback { my $self = shift->_get_self; - return $self->_engine->rollback( $self, @_ ); + $self->lock_exclusive; + my $rv = eval { $self->_engine->rollback( $self, @_ ) }; + my $e = $@; + $self->unlock; + die $e if $e; + return $rv; } sub commit { my $self = shift->_get_self; - return $self->_engine->commit( $self, @_ ); + $self->lock_exclusive; + my $rv = eval { $self->_engine->commit( $self, @_ ) }; + my $e = $@; + $self->unlock; + die $e if $e; + return $rv; } -## # Accessor methods -## - sub _engine { my $self = $_[0]->_get_self; return $self->{engine}; } -sub _storage { - my $self = $_[0]->_get_self; - return $self->{storage}; -} - sub _type { my $self = $_[0]->_get_self; return $self->{type}; @@ -379,142 +526,112 @@ sub _staleness { return $self->{staleness}; } -sub _fh { - my $self = $_[0]->_get_self; - return $self->_storage->{fh}; -} - -## # Utility methods -## - sub _throw_error { - die "DBM::Deep: $_[1]\n"; my $n = 0; while( 1 ) { my @caller = caller( ++$n ); next if $caller[0] =~ m/^DBM::Deep/; die "DBM::Deep: $_[1] at $0 line $caller[2]\n"; - last; } } +# Store single hash key/value or array element in database. sub STORE { - ## - # Store single hash key/value or array element in database. - ## my $self = shift->_get_self; my ($key, $value) = @_; + warn "STORE($self, '$key', '@{[defined$value?$value:'undef']}')\n" if DEBUG; - if ( !FileHandle::Fmode::is_W( $self->_fh ) ) { + unless ( $self->_engine->storage->is_writable ) { $self->_throw_error( 'Cannot write to a readonly filehandle' ); } - ## - # Request exclusive lock for writing - ## - $self->lock( LOCK_EX ); + $self->lock_exclusive; # User may be storing a complex value, in which case we do not want it run # through the filtering system. - if ( !ref($value) && $self->_storage->{filter_store_value} ) { - $value = $self->_storage->{filter_store_value}->( $value ); + if ( !ref($value) && $self->_engine->storage->{filter_store_value} ) { + $value = $self->_engine->storage->{filter_store_value}->( $value ); } - $self->_engine->write_value( $self, $key, $value); + $self->_engine->write_value( $self, $key, $value ); - $self->unlock(); + $self->unlock; return 1; } +# Fetch single value or element given plain key or array index sub FETCH { - ## - # Fetch single value or element given plain key or array index - ## my $self = shift->_get_self; my ($key) = @_; + warn "FETCH($self, '$key')\n" if DEBUG; - ## - # Request shared lock for reading - ## - $self->lock( LOCK_SH ); + $self->lock_shared; - my $result = $self->_engine->read_value( $self, $key); + my $result = $self->_engine->read_value( $self, $key ); - $self->unlock(); + $self->unlock; # Filters only apply to scalar values, so the ref check is making # sure the fetched bucket is a scalar, not a child hash or array. - return ($result && !ref($result) && $self->_storage->{filter_fetch_value}) - ? $self->_storage->{filter_fetch_value}->($result) + return ($result && !ref($result) && $self->_engine->storage->{filter_fetch_value}) + ? $self->_engine->storage->{filter_fetch_value}->($result) : $result; } +# Delete single key/value pair or element given plain key or array index sub DELETE { - ## - # Delete single key/value pair or element given plain key or array index - ## my $self = shift->_get_self; my ($key) = @_; + warn "DELETE($self, '$key')\n" if DEBUG; - if ( !FileHandle::Fmode::is_W( $self->_fh ) ) { + unless ( $self->_engine->storage->is_writable ) { $self->_throw_error( 'Cannot write to a readonly filehandle' ); } - ## - # Request exclusive lock for writing - ## - $self->lock( LOCK_EX ); + $self->lock_exclusive; ## # Delete bucket ## my $value = $self->_engine->delete_key( $self, $key); - if (defined $value && !ref($value) && $self->_storage->{filter_fetch_value}) { - $value = $self->_storage->{filter_fetch_value}->($value); + if (defined $value && !ref($value) && $self->_engine->storage->{filter_fetch_value}) { + $value = $self->_engine->storage->{filter_fetch_value}->($value); } - $self->unlock(); + $self->unlock; return $value; } +# Check if a single key or element exists given plain key or array index sub EXISTS { - ## - # Check if a single key or element exists given plain key or array index - ## my $self = shift->_get_self; my ($key) = @_; + warn "EXISTS($self, '$key')\n" if DEBUG; - ## - # Request shared lock for reading - ## - $self->lock( LOCK_SH ); + $self->lock_shared; my $result = $self->_engine->key_exists( $self, $key ); - $self->unlock(); + $self->unlock; return $result; } +# Clear all keys from hash, or all elements from array. sub CLEAR { - ## - # Clear all keys from hash, or all elements from array. - ## my $self = shift->_get_self; + warn "CLEAR($self)\n" if DEBUG; - if ( !FileHandle::Fmode::is_W( $self->_fh ) ) { + unless ( $self->_engine->storage->is_writable ) { $self->_throw_error( 'Cannot write to a readonly filehandle' ); } - ## - # Request exclusive lock for writing - ## - $self->lock( LOCK_EX ); + $self->lock_exclusive; #XXX Rewrite this dreck to do it in the engine as a tight loop vs. # iterating over keys - such a WASTE - is this required for transactional @@ -536,21 +653,21 @@ sub CLEAR { $self->STORESIZE( 0 ); } - $self->unlock(); + $self->unlock; return 1; } -## # Public method aliases -## -sub put { (shift)->STORE( @_ ) } -sub store { (shift)->STORE( @_ ) } -sub get { (shift)->FETCH( @_ ) } -sub fetch { (shift)->FETCH( @_ ) } +sub put { (shift)->STORE( @_ ) } +sub get { (shift)->FETCH( @_ ) } +sub store { (shift)->STORE( @_ ) } +sub fetch { (shift)->FETCH( @_ ) } sub delete { (shift)->DELETE( @_ ) } sub exists { (shift)->EXISTS( @_ ) } -sub clear { (shift)->CLEAR( @_ ) } +sub clear { (shift)->CLEAR( @_ ) } + +sub _dump_file {shift->_get_self->_engine->_dump_file;} 1; __END__