From: rkinyon Date: Tue, 2 Oct 2007 03:11:45 +0000 (+0000) Subject: r8223@rob-kinyons-computer-2 (orig r10043): rkinyon | 2007-10-01 23:11:14 -0400 X-Git-Tag: 1-0006~1 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e00d0eb34a38786a1df0119d636145715c4e376a;p=dbsrgits%2FDBM-Deep.git r8223@rob-kinyons-computer-2 (orig r10043): rkinyon | 2007-10-01 23:11:14 -0400 r8215@rob-kinyons-computer-2 (orig r10039): rkinyon | 2007-10-01 21:25:29 -0400 Removed usage of Clone from the code, replacing it with a hand-rolled datawalk r8222@rob-kinyons-computer-2 (orig r10042): rkinyon | 2007-10-01 23:10:50 -0400 Final prep for 1.0006 release --- diff --git a/Build.PL b/Build.PL index 595b201..abcf310 100644 --- a/Build.PL +++ b/Build.PL @@ -7,11 +7,10 @@ my $build = Module::Build->new( license => 'perl', requires => { 'perl' => '5.006_000', - 'Clone' => '0.01', - 'Digest::MD5' => '1.00', 'Fcntl' => '0.01', - 'FileHandle::Fmode' => '0.05', 'Scalar::Util' => '1.14', + 'Digest::MD5' => '1.00', + 'FileHandle::Fmode' => '0.05', }, optional => { }, @@ -26,7 +25,7 @@ my $build = Module::Build->new( }, create_makefile_pl => 'traditional', add_to_cleanup => [ - 'META.yml', '*.bak', '*.gz', 'Makefile.PL', 't/test*.db', 'cover_db', + 'META.yml', '*.bak', '*.gz', 'Makefile.PL', 'cover_db', ], test_files => 't/??_*.t', ); diff --git a/Changes b/Changes index 8618e7c..22535e0 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,15 @@ Revision history for DBM::Deep. +1.0006 Oct 01 23:15:00 2007 EDT + - (This version is compatible with 1.0005) + - Removed Clone and replaced it with a hand-written datastructure walker. + - This greatly reduces the footprint of a large import + - This bypasses a failure of Clone under Perl 5.9.5 + - Moved t/37_delete_edge_cases.t to t_attic because it wasn't really used + - import() has a stricter API now. This is a potentially incompatible API + change. Only HASH and ARRAY refs are now allowed and they must match the type + of the object being imported into. + 1.0005 Oct 01 11:15:00 2007 EDT - (This version is compatible with 1.0004) - Added proper singleton support. This means that the following now works: diff --git a/MANIFEST b/MANIFEST index 8862a0f..a0bbd13 100644 --- a/MANIFEST +++ b/MANIFEST @@ -50,7 +50,6 @@ t/32_dash_ell.t t/33_transactions.t t/34_transaction_arrays.t t/35_transaction_multiple.t -t/37_delete_edge_cases.t t/38_data_sector_size.t t/39_singletons.t t/40_freespace.t diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm index 8eb36b9..d34e675 100644 --- a/lib/DBM/Deep.pm +++ b/lib/DBM/Deep.pm @@ -5,11 +5,10 @@ use 5.006_000; use strict; use warnings; -our $VERSION = q(1.0005); +our $VERSION = q(1.0006); use Fcntl qw( :flock ); -use Clone (); use Digest::MD5 (); use FileHandle::Fmode (); use Scalar::Util (); @@ -202,29 +201,85 @@ 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; + + DBM::Deep->_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 + # Perl calls import() on use -- ignore + return if !ref $_[0]; 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 ) { + DBM::Deep->_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 ) { + DBM::Deep->_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; } @@ -244,6 +299,7 @@ sub optimize { #XXX Do we have to lock the tempfile? + #XXX Should we use tempfile() here instead of a hard-coded name? my $db_temp = DBM::Deep->new( file => $self->_storage->{file} . '.tmp', type => $self->_type, diff --git a/lib/DBM/Deep.pod b/lib/DBM/Deep.pod index 6b5b2e6..8100fec 100644 --- a/lib/DBM/Deep.pod +++ b/lib/DBM/Deep.pod @@ -387,16 +387,26 @@ value. =item * lock() / unlock() -q.v. Locking. +q.v. L for more info. =item * optimize() -Recover lost disk space. This is important to do, especially if you use -transactions. +This will compress the datafile so that it takes up as little space as possible. +There is a freespace manager so that when space is freed up, it is used before +extending the size of the datafile. But, that freespace just sits in the datafile +unless C is called. -=item * import() / export() +=item * import() -Data going in and out. +Unlike simple assignment, C does not tie the right-hand side. Instead, +a copy of your data is put into the DB. C takes either an arrayref (if +your DB is an array) or a hashref (if your DB is a hash). C will die +if anything else is passed in. + +=item * export() + +This returns a complete copy of the data structure at the point you do the export. +This copy is in RAM, not on disk like the DB is. =item * begin_work() / commit() / rollback() @@ -1027,12 +1037,12 @@ B report on this distribution's test suite. ------------------------------------------ ------ ------ ------ ------ ------ File stmt bran cond sub total ------------------------------------------ ------ ------ ------ ------ ------ - blib/lib/DBM/Deep.pm 96.9 88.3 90.5 100.0 95.7 + blib/lib/DBM/Deep.pm 97.2 90.9 83.3 100.0 95.4 blib/lib/DBM/Deep/Array.pm 100.0 95.7 100.0 100.0 99.0 - blib/lib/DBM/Deep/Engine.pm 95.5 84.7 81.6 98.4 92.4 + blib/lib/DBM/Deep/Engine.pm 95.6 84.7 81.6 98.4 92.5 blib/lib/DBM/Deep/File.pm 97.2 81.6 66.7 100.0 91.9 blib/lib/DBM/Deep/Hash.pm 100.0 100.0 100.0 100.0 100.0 - Total 96.7 87.0 83.3 99.2 94.1 + Total 96.7 87.5 82.2 99.2 94.1 ------------------------------------------ ------ ------ ------ ------ ------ =head1 MORE INFORMATION diff --git a/lib/DBM/Deep/Array.pm b/lib/DBM/Deep/Array.pm index eb092ac..6f78c0d 100644 --- a/lib/DBM/Deep/Array.pm +++ b/lib/DBM/Deep/Array.pm @@ -5,7 +5,7 @@ use 5.006_000; use strict; use warnings; -our $VERSION = q(1.0005); +our $VERSION = q(1.0006); # This is to allow DBM::Deep::Array to handle negative indices on # its own. Otherwise, Perl would intercept the call to negative @@ -20,16 +20,7 @@ sub _get_self { eval { local $SIG{'__DIE__'}; tied( @{$_[0]} ) } || $_[0] } -sub _repr { shift;[ @_ ] } - -sub _import { - my $self = shift; - my ($struct) = @_; - - $self->push( @$struct ); - - return 1; -} +sub _repr { [] } sub TIEARRAY { my $class = shift; diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm index f8656a3..1a841f8 100644 --- a/lib/DBM/Deep/Engine.pm +++ b/lib/DBM/Deep/Engine.pm @@ -5,7 +5,7 @@ use 5.006_000; use strict; use warnings; -our $VERSION = q(1.0005); +our $VERSION = q(1.0006); use Scalar::Util (); @@ -1720,7 +1720,8 @@ sub free { } # Rebless the object into DBM::Deep::Null. - %{ $self->engine->cache->{ $self->offset } } = (); + eval { %{ $self->engine->cache->{ $self->offset } } = (); }; + eval { @{ $self->engine->cache->{ $self->offset } } = (); }; bless $self->engine->cache->{ $self->offset }, 'DBM::Deep::Null'; delete $self->engine->cache->{ $self->offset }; diff --git a/lib/DBM/Deep/File.pm b/lib/DBM/Deep/File.pm index 6571c2e..83835d9 100644 --- a/lib/DBM/Deep/File.pm +++ b/lib/DBM/Deep/File.pm @@ -5,7 +5,7 @@ use 5.006_000; use strict; use warnings; -our $VERSION = q(1.0005); +our $VERSION = q(1.0006); use Fcntl qw( :DEFAULT :flock :seek ); diff --git a/lib/DBM/Deep/Hash.pm b/lib/DBM/Deep/Hash.pm index a342d62..7bca7ce 100644 --- a/lib/DBM/Deep/Hash.pm +++ b/lib/DBM/Deep/Hash.pm @@ -5,7 +5,7 @@ use 5.006_000; use strict; use warnings; -our $VERSION = q(1.0005); +our $VERSION = q(1.0006); use base 'DBM::Deep'; @@ -13,19 +13,7 @@ sub _get_self { eval { local $SIG{'__DIE__'}; tied( %{$_[0]} ) } || $_[0] } -#XXX Need to add a check here for @_ % 2 -sub _repr { shift;return { @_ } } - -sub _import { - my $self = shift; - my ($struct) = @_; - - foreach my $key (keys %$struct) { - $self->put($key, $struct->{$key}); - } - - return 1; -} +sub _repr { return {} } sub TIEHASH { ## diff --git a/t/17_import.t b/t/17_import.t index b4ff262..c5e034e 100644 --- a/t/17_import.t +++ b/t/17_import.t @@ -2,12 +2,49 @@ # DBM::Deep Test ## use strict; -use Test::More tests => 11; +use Test::More tests => 17; use Test::Deep; +use Test::Exception; use t::common qw( new_fh ); use_ok( 'DBM::Deep' ); +# Failure cases to make sure that things are caught right. +foreach my $type ( DBM::Deep->TYPE_HASH, DBM::Deep->TYPE_ARRAY ) { + my ($fh, $filename) = new_fh(); + my $db = DBM::Deep->new({ + file => $filename, + type => $type, + }); + + # Load a scalar + throws_ok { + $db->import( 'foo' ); + } qr/Cannot import a scalar/, "Importing a scalar to type '$type' fails"; + + # Load a ref of the wrong type + # Load something with bad stuff in it + my $x = 3; + if ( $type eq 'A' ) { + throws_ok { + $db->import( { foo => 'bar' } ); + } qr/Cannot import a hash into an array/, "Wrong type fails"; + + throws_ok { + $db->import( [ \$x ] ); + } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails"; + } + else { + throws_ok { + $db->import( [ 1 .. 3 ] ); + } qr/Cannot import an array into a hash/, "Wrong type fails"; + + throws_ok { + $db->import( { foo => \$x } ); + } qr/Storage of references of type 'SCALAR' is not supported/, "Bad stuff fails"; + } +} + { my ($fh, $filename) = new_fh(); my $db = DBM::Deep->new({ @@ -25,7 +62,7 @@ use_ok( 'DBM::Deep' ); hash1 => { subkey1 => "subvalue1", subkey2 => "subvalue2", - subkey3 => bless( {}, 'Foo' ), + subkey3 => bless( { a => 'b' }, 'Foo' ), } }; @@ -40,7 +77,7 @@ use_ok( 'DBM::Deep' ); hash1 => { subkey1 => "subvalue1", subkey2 => "subvalue2", - subkey3 => useclass( bless {}, 'Foo' ), + subkey3 => useclass( bless { a => 'b' }, 'Foo' ), }, }), "Everything matches", @@ -56,9 +93,6 @@ use_ok( 'DBM::Deep' ); } { - diag "\nThere seems to be a bug in Clone on Perl 5.9+ that is causing\nthese tests to fail." - if $] >= 5.009; - my ($fh, $filename) = new_fh(); my $db = DBM::Deep->new({ file => $filename, diff --git a/t/18_export.t b/t/18_export.t index 9cca868..949697a 100644 --- a/t/18_export.t +++ b/t/18_export.t @@ -33,7 +33,7 @@ my $db = DBM::Deep->new({ ## # Create structure in DB ## -$db->import( %struct ); +$db->import( \%struct ); ## # Export entire thing diff --git a/t/19_crossref.t b/t/19_crossref.t index c41747d..67a3589 100644 --- a/t/19_crossref.t +++ b/t/19_crossref.t @@ -40,12 +40,12 @@ SKIP: { ## # Create structure in $db ## - $db->import( + $db->import({ hash1 => { subkey1 => "subvalue1", subkey2 => "subvalue2", } - ); + }); is( $db->{hash1}{subkey1}, 'subvalue1', "Value imported correctly" ); is( $db->{hash1}{subkey2}, 'subvalue2', "Value imported correctly" ); diff --git a/t/22_internal_copy.t b/t/22_internal_copy.t index 9de69f4..f1a51a5 100644 --- a/t/22_internal_copy.t +++ b/t/22_internal_copy.t @@ -13,7 +13,7 @@ my $db = DBM::Deep->new( $filename ); ## # Create structure in $db ## -$db->import( +$db->import({ hash1 => { subkey1 => "subvalue1", subkey2 => "subvalue2", @@ -21,7 +21,7 @@ $db->import( hash2 => { subkey3 => 'subvalue3', }, -); +}); is( $db->{hash1}{subkey1}, 'subvalue1', "Value imported correctly" ); is( $db->{hash1}{subkey2}, 'subvalue2', "Value imported correctly" ); diff --git a/t/44_upgrade_db.t b/t/44_upgrade_db.t index 759dbf0..f72ef70 100644 --- a/t/44_upgrade_db.t +++ b/t/44_upgrade_db.t @@ -13,7 +13,7 @@ BEGIN { } } -plan tests => 212; +plan tests => 222; use t::common qw( new_fh ); use File::Spec; @@ -63,7 +63,7 @@ my @output_versions = ( '0.981', '0.982', '0.983', '0.99_01', '0.99_02', '0.99_03', '0.99_04', '1.00', '1.000', '1.0000', '1.0001', '1.0002', - '1.0003', '1.0004', '1.0005', + '1.0003', '1.0004', '1.0005', '1.0006', ); foreach my $input_filename ( @@ -84,6 +84,15 @@ foreach my $input_filename ( "-version $v", ); + # Clone was removed as a requirement in 1.0006 + if ( $output =~ /Can\'t locate Clone\.pm in \@INC/ ) { + ok( 1 ); + unless ( $input_filename =~ /_/ || $v =~ /_/ ) { + ok( 1 ); ok( 1 ); + } + next; + } + if ( $input_filename =~ /_/ ) { is( $output, "'$input_filename' is a dev release and not supported.\n$short", @@ -117,7 +126,7 @@ foreach my $input_filename ( eval "use DBM::Deep::10002"; $db = DBM::Deep::10002->new( $output_filename ); } - elsif ( $v =~ /^1\.000[3-5]/ ) { + elsif ( $v =~ /^1\.000[3-6]/ ) { push @INC, 'lib'; eval "use DBM::Deep"; $db = DBM::Deep->new( $output_filename ); diff --git a/t/37_delete_edge_cases.t b/t_attic/37_delete_edge_cases.t similarity index 100% rename from t/37_delete_edge_cases.t rename to t_attic/37_delete_edge_cases.t diff --git a/utils/upgrade_db.pl b/utils/upgrade_db.pl index 3a7c86d..b80889b 100755 --- a/utils/upgrade_db.pl +++ b/utils/upgrade_db.pl @@ -28,7 +28,7 @@ my %is_dev = ( my %opts = ( man => 0, help => 0, - version => '1.0005', + version => '1.0006', autobless => 1, ); GetOptions( \%opts, @@ -58,6 +58,9 @@ my %db; my $mod = $headerver_to_module{ $ver }; eval "use $mod;"; + if ( $@ ) { + _exit( "Cannot load '$mod' to read header version '$ver':\n\t$@" ); + } $db{input} = $mod->new({ file => $opts{input}, locking => 1, @@ -77,7 +80,7 @@ my %db; elsif ( $ver =~ /^1\.000?[0-2]?/) { $ver = 2; } - elsif ( $ver =~ /^1\.000[3-5]/) { + elsif ( $ver =~ /^1\.000[3-6]/) { $ver = 3; } else { @@ -93,6 +96,9 @@ my %db; my $mod = $headerver_to_module{ $ver }; eval "use $mod;"; + if ( $@ ) { + _exit( "Cannot load '$mod' to read header version '$ver':\n\t$@" ); + } $db{output} = $mod->new({ file => $opts{output}, locking => 1,