r8215@rob-kinyons-computer-2 (orig r10039): rkinyon | 2007-10-01 21:25:29 -0400
rkinyon [Tue, 2 Oct 2007 03:11:14 +0000 (03:11 +0000)]
 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

16 files changed:
Build.PL
Changes
MANIFEST
lib/DBM/Deep.pm
lib/DBM/Deep.pod
lib/DBM/Deep/Array.pm
lib/DBM/Deep/Engine.pm
lib/DBM/Deep/File.pm
lib/DBM/Deep/Hash.pm
t/17_import.t
t/18_export.t
t/19_crossref.t
t/22_internal_copy.t
t/44_upgrade_db.t
t_attic/37_delete_edge_cases.t [moved from t/37_delete_edge_cases.t with 100% similarity]
utils/upgrade_db.pl

index 595b201..abcf310 100644 (file)
--- 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 (file)
--- 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:
index 8862a0f..a0bbd13 100644 (file)
--- 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
index 8eb36b9..d34e675 100644 (file)
@@ -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,
index 6b5b2e6..8100fec 100644 (file)
@@ -387,16 +387,26 @@ value.
 
 =item * lock() / unlock()
 
-q.v. Locking.
+q.v. L</LOCKING> 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<optimize()> is called.
 
-=item * import() / export()
+=item * import()
 
-Data going in and out.
+Unlike simple assignment, C<import()> does not tie the right-hand side. Instead,
+a copy of your data is put into the DB. C<import()> takes either an arrayref (if
+your DB is an array) or a hashref (if your DB is a hash). C<import()> 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<Devel::Cover> 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
index eb092ac..6f78c0d 100644 (file)
@@ -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;
index f8656a3..1a841f8 100644 (file)
@@ -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 };
 
index 6571c2e..83835d9 100644 (file)
@@ -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 );
 
index a342d62..7bca7ce 100644 (file)
@@ -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 {
     ##
index b4ff262..c5e034e 100644 (file)
@@ -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,
index 9cca868..949697a 100644 (file)
@@ -33,7 +33,7 @@ my $db = DBM::Deep->new({
 ##
 # Create structure in DB
 ##
-$db->import( %struct );
+$db->import( \%struct );
 
 ##
 # Export entire thing
index c41747d..67a3589 100644 (file)
@@ -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" );
 
index 9de69f4..f1a51a5 100644 (file)
@@ -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" );
index 759dbf0..f72ef70 100644 (file)
@@ -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 );
index 3a7c86d..b80889b 100755 (executable)
@@ -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,