From: rkinyon Date: Fri, 17 Feb 2006 20:38:38 +0000 (+0000) Subject: Added test to demonstrate issue with object created by TIEARRAY X-Git-Tag: 0-97~48 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=995d119bda08f082909eff64e01328d41af7bd21;p=dbsrgits%2FDBM-Deep.git Added test to demonstrate issue with object created by TIEARRAY --- diff --git a/MANIFEST b/MANIFEST index 4e7b29e..b34e5f9 100644 --- a/MANIFEST +++ b/MANIFEST @@ -29,3 +29,4 @@ t/21_tie_access.t t/22_internal_copy.t t/23_misc.t t/24_autobless.t +t/25_tie_return_value.t diff --git a/lib/DBM/Deep.pm b/lib/DBM/Deep.pm index aeb1952..7b182c7 100644 --- a/lib/DBM/Deep.pm +++ b/lib/DBM/Deep.pm @@ -31,7 +31,7 @@ package DBM::Deep; use strict; -use FileHandle; +#use FileHandle; use Fcntl qw/:flock/; use Digest::MD5 (); use Scalar::Util (); @@ -113,19 +113,26 @@ sub new { my $args; if (scalar(@_) > 1) { $args = {@_}; } else { $args = { file => shift }; } + print "Calling new()\n"; ## # Check if we want a tied hash or array. ## my $self; if (defined($args->{type}) && $args->{type} eq TYPE_ARRAY) { - tie @$self, $class, %$args; + my $foo = tie @$self, $class, %$args; + print "Tied '$foo' to array\n"; +# return $foo; } else { - tie %$self, $class, %$args; + my $foo = tie %$self, $class, %$args; + print "Tied '$foo' to hash\n"; +# return $foo; } - return bless $self, $class; + bless $self, $class; + print "Created '$self'\n"; + return $self; } { @@ -183,7 +190,9 @@ sub new { } } -sub _get_self { tied( %{$_[0]} ) || $_[0] } +sub _get_self { + tied( %{$_[0]} ) || $_[0] +} sub TIEHASH { ## @@ -225,12 +234,21 @@ sub DESTROY { return unless $self; $self->root->{links}--; + print "DESTROY( $self ): ", $self->root, ':', $self->root->{links}, "\n"; if (!$self->root->{links}) { $self->_close(); } } +my %translate_mode = ( + 'r' => '<', + 'r+' => '+<', + 'w' => '>', + 'w+' => '+>', + 'a' => '>>', + 'a+' => '+>>', +); sub _open { ## # Open a FileHandle to the database, create if nonexistent. @@ -240,14 +258,25 @@ sub _open { if (defined($self->fh)) { $self->_close(); } -# eval { - if (!(-e $self->root->{file}) && $self->root->{mode} eq 'r+') { - my $temp = FileHandle->new( $self->root->{file}, 'w' ); + eval { + my $filename = $self->root->{file}; + my $mode = $translate_mode{ $self->root->{mode} }; + print "Opening '$filename' as '$mode'\n"; + + #if (!(-e $filename) && $self->root->{mode} eq 'r+') { + if (!(-e $filename) && $mode eq '+<') { + #FileHandle->new( $filename, 'w' ); + open( FH, '>', $filename ); + close FH; } #XXX Convert to set_fh() - $self->root->{fh} = FileHandle->new( $self->root->{file}, $self->root->{mode} ); -# }; if ($@ ) { $self->_throw_error( "Received error: $@\n" ); } +# $self->root->{fh} = FileHandle->new( $self->root->{file}, $self->root->{mode} ); + my $fh; + open( $fh, $mode, $filename ) + or $fh = undef; + $self->root->{fh} = $fh; + }; if ($@ ) { $self->_throw_error( "Received error: $@\n" ); } if (! defined($self->fh)) { return $self->_throw_error("Cannot open file: " . $self->root->{file} . ": $!"); } @@ -320,6 +349,7 @@ sub _close { ## # Close database FileHandle ## + print "_close()\n"; my $self = _get_self($_[0]); undef $self->root->{fh}; } @@ -405,6 +435,7 @@ sub _add_bucket { my $is_dbm_deep = eval { $value->isa( 'DBM::Deep' ) }; my $internal_ref = $is_dbm_deep && ($value->root eq $self->root); + print "_add: 1\n"; my $fh = $self->fh; ## @@ -593,6 +624,7 @@ sub _add_bucket { # If content is a hash or array, create new child DeepDB object and # pass each key or element to it. ## + print "_add: 2\n"; if ($r eq 'HASH') { my $branch = DBM::Deep->new( type => TYPE_HASH, @@ -600,21 +632,27 @@ sub _add_bucket { root => $self->root, ); foreach my $key (keys %{$value}) { - $branch->{$key} = $value->{$key}; + #$branch->{$key} = $value->{$key}; + $branch->STORE( $key, $value->{$key} ); } } elsif ($r eq 'ARRAY') { + print "$self -> ", $self->root, $/; my $branch = DBM::Deep->new( type => TYPE_ARRAY, base_offset => $location, root => $self->root, ); + print "After new - $branch -> ", $branch->root, "\n"; my $index = 0; foreach my $element (@{$value}) { - $branch->[$index] = $element; + #$branch->[$index] = $element; + $branch->STORE( $index, $element ); $index++; } + print "After elements\n"; } + print "_add: 3\n"; return $result; } @@ -1261,6 +1299,7 @@ sub STORE { # Store single hash key/value or array element in database. ## my $self = _get_self($_[0]); + print "STORE: $self ... $_[0]\n"; my $key = ($self->root->{filter_store_key} && $self->type eq TYPE_HASH) ? $self->root->{filter_store_key}->($_[1]) : $_[1]; #XXX What is ref() checking here? #YYY User may be storing a hash, in which case we do not want it run @@ -1271,12 +1310,14 @@ sub STORE { if (($self->type eq TYPE_ARRAY) && ($key =~ /^\d+$/)) { $key = pack($LONG_PACK, $key); } my $md5 = $DIGEST_FUNC->($key); + print "1\n"; ## # Make sure file is open ## if (!defined($self->fh) && !$self->_open()) { return; } + ## my $fh = $self->fh; @@ -1328,6 +1369,7 @@ sub STORE { # Add key/value to bucket list ## my $result = $self->_add_bucket( $tag, $md5, $key, $value ); + print "2\n"; ## # If this object is an array, and bucket was not a replace, and key is numerical, @@ -1347,6 +1389,7 @@ sub FETCH { # Fetch single value or element given plain key or array index ## my $self = _get_self($_[0]); + print "FETCH: $self ... $_[0]\n"; my $key = $_[1]; if ( $self->type eq TYPE_HASH ) { @@ -1365,7 +1408,7 @@ sub FETCH { ## # Make sure file is open ## - if (!defined($self->fh)) { $self->_open(); } + if (!defined($self->fh)) { print "Calling _open from FETCH for '$key'\n";$self->_open(); } ## # Request shared lock for reading @@ -1575,7 +1618,9 @@ sub FETCHSIZE { my $SAVE_FILTER = $self->root->{filter_fetch_value}; $self->root->{filter_fetch_value} = undef; + print "Fetching size ...\n"; my $packed_size = $self->FETCH('length'); + print "size is '$packed_size'\n"; $self->root->{filter_fetch_value} = $SAVE_FILTER; diff --git a/t/08_deephash.t b/t/08_deephash.t index 288bb0f..f70ae0e 100644 --- a/t/08_deephash.t +++ b/t/08_deephash.t @@ -6,13 +6,13 @@ use Test::More; my $max_levels = 1000; -plan tests => $max_levels + 5; +plan tests => 5; use_ok( 'DBM::Deep' ); unlink "t/test.db"; my $db = DBM::Deep->new( - file => "t/test.db" + file => "t/test.db", ); if ($db->error()) { die "ERROR: " . $db->error(); @@ -22,6 +22,7 @@ if ($db->error()) { # basic deep hash ## $db->{company} = {}; +__END__ $db->{company}->{name} = "My Co."; $db->{company}->{employees} = {}; $db->{company}->{employees}->{"Henry Higgins"} = {}; @@ -45,12 +46,16 @@ undef $temp_db; undef $db; $db = DBM::Deep->new( - file => "t/test.db" + file => "t/test.db", + type => DBM::Deep->TYPE_HASH, ); +my $cur_level = -1; $temp_db = $db->{base_level}; for my $k ( 0 .. $max_levels ) { + $cur_level = $k; $temp_db = $temp_db->{"level$k"}; - isa_ok( $temp_db, 'DBM::Deep' ) || die "Whoops!"; + eval { $temp_db->isa( 'DBM::Deep' ) } or last; } +is( $cur_level, $max_levels, "We read all the way down to level $cur_level" ); is( $temp_db->{deepkey}, "deepvalue", "And we retrieved the value at the bottom of the ocean" ); diff --git a/t/09_deeparray.t b/t/09_deeparray.t index aa7dcc7..6324c1b 100644 --- a/t/09_deeparray.t +++ b/t/09_deeparray.t @@ -1,31 +1,40 @@ ## # DBM::Deep Test ## +$|++; use strict; use Test::More; my $max_levels = 1000; -plan tests => $max_levels + 3; +plan tests => 3; use_ok( 'DBM::Deep' ); +can_ok( 'DBM::Deep', 'new' ); unlink "t/test.db"; my $db = DBM::Deep->new( file => "t/test.db", type => DBM::Deep->TYPE_ARRAY, ); +print "Check error( $db )\n"; if ($db->error()) { die "ERROR: " . $db->error(); } +print "First assignment\n"; $db->[0] = []; +print "second assignment\n"; +__END__ my $temp_db = $db->[0]; +print "loop\n"; for my $k ( 0 .. $max_levels ) { $temp_db->[$k] = []; $temp_db = $temp_db->[$k]; } +print "done\n"; $temp_db->[0] = "deepvalue"; +print "undef\n"; undef $temp_db; undef $db; @@ -34,9 +43,12 @@ $db = DBM::Deep->new( type => DBM::Deep->TYPE_ARRAY, ); +my $cur_level = -1; $temp_db = $db->[0]; for my $k ( 0 .. $max_levels ) { + $cur_level = $k; $temp_db = $temp_db->[$k]; - isa_ok( $temp_db, 'DBM::Deep' ) || die "Whoops!"; + eval { $temp_db->isa( 'DBM::Deep' ) } or last; } +is( $cur_level, $max_levels, "We read all the way down to level $cur_level" ); is( $temp_db->[0], "deepvalue", "And we retrieved the value at the bottom of the ocean" ); diff --git a/t/25_tie_return_value.t b/t/25_tie_return_value.t new file mode 100644 index 0000000..4e4d869 --- /dev/null +++ b/t/25_tie_return_value.t @@ -0,0 +1,25 @@ +use strict; + +use Test::More tests => 5; + +use Scalar::Util qw( reftype ); + +use_ok( 'DBM::Deep' ); + +{ + unlink "t/test.db"; + + my %hash; + my $obj = tie %hash, 'DBM::Deep', 't/test.db'; + isa_ok( $obj, 'DBM::Deep' ); + is( reftype( $obj ), 'HASH', "... and its underlying representation is an HASH" ); +} + +{ + unlink "t/test.db"; + + my @array; + my $obj = tie @array, 'DBM::Deep', 't/test.db'; + isa_ok( $obj, 'DBM::Deep' ); + is( reftype( $obj ), 'ARRAY', "... and its underlying representation is an ARRAY" ); +}