From: rkinyon Date: Tue, 2 Oct 2007 01:25:29 +0000 (+0000) Subject: Removed usage of Clone from the code, replacing it with a hand-rolled datawalk X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4301e8795213becc8854d413062d49746cdf5a31;p=dbsrgits%2FDBM-Deep.git Removed usage of Clone from the code, replacing it with a hand-rolled datawalk --- diff --git a/Build.PL b/Build.PL index 595b201..6ff3460 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', + '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..df69cf8 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,13 @@ Revision history for DBM::Deep. +1.0006 Oct 01 11:15:00 2007 EDT + - (This version is compatible with 1.0005) + - Removed Clone and replaced it with a hand-written datastructure walker. + - This heavily reduces the footprint of a large import + - 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. + 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..823ed75 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() 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..ac67de8 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 (); 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..42137a8 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", 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..d2d6274 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 ( @@ -117,7 +117,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..e7f4178 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, @@ -77,7 +77,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 {