Added test to demonstrate issue with object created by TIEARRAY

diff --git a/MANIFEST b/MANIFEST
index 4e7b29e..b34e5f9 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
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" );
+}