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
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 => {
},
},
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',
);
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:
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
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 ();
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;
}
#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,
=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()
------------------------------------------ ------ ------ ------ ------ ------
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
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
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;
use strict;
use warnings;
-our $VERSION = q(1.0005);
+our $VERSION = q(1.0006);
use Scalar::Util ();
}
# 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 };
use strict;
use warnings;
-our $VERSION = q(1.0005);
+our $VERSION = q(1.0006);
use Fcntl qw( :DEFAULT :flock :seek );
use strict;
use warnings;
-our $VERSION = q(1.0005);
+our $VERSION = q(1.0006);
use base 'DBM::Deep';
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 {
##
# 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({
hash1 => {
subkey1 => "subvalue1",
subkey2 => "subvalue2",
- subkey3 => bless( {}, 'Foo' ),
+ subkey3 => bless( { a => 'b' }, 'Foo' ),
}
};
hash1 => {
subkey1 => "subvalue1",
subkey2 => "subvalue2",
- subkey3 => useclass( bless {}, 'Foo' ),
+ subkey3 => useclass( bless { a => 'b' }, 'Foo' ),
},
}),
"Everything matches",
}
{
- 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,
##
# Create structure in DB
##
-$db->import( %struct );
+$db->import( \%struct );
##
# Export entire thing
##
# 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" );
##
# Create structure in $db
##
-$db->import(
+$db->import({
hash1 => {
subkey1 => "subvalue1",
subkey2 => "subvalue2",
hash2 => {
subkey3 => 'subvalue3',
},
-);
+});
is( $db->{hash1}{subkey1}, 'subvalue1', "Value imported correctly" );
is( $db->{hash1}{subkey2}, 'subvalue2', "Value imported correctly" );
}
}
-plan tests => 212;
+plan tests => 222;
use t::common qw( new_fh );
use File::Spec;
'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 (
"-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",
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 );
my %opts = (
man => 0,
help => 0,
- version => '1.0005',
+ version => '1.0006',
autobless => 1,
);
GetOptions( \%opts,
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,
elsif ( $ver =~ /^1\.000?[0-2]?/) {
$ver = 2;
}
- elsif ( $ver =~ /^1\.000[3-5]/) {
+ elsif ( $ver =~ /^1\.000[3-6]/) {
$ver = 3;
}
else {
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,
projects / dbsrgits/DBM-Deep.git / commitdiff