Added tests for storing tied stuff

diff --git a/MANIFEST b/MANIFEST
index 5ad5076..d981c61 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -37,4 +37,4 @@ t/26_scalar_ref.t
 t/27_filehandle.t
 t/28_DATA.t
 t/29_freespace_manager.t
-
+t/30_already_tied.t

diff --git a/lib/DBM/Deep/Engine.pm b/lib/DBM/Deep/Engine.pm
index ad75d91..0cc4bcb 100644 (file)
--- a/lib/DBM/Deep/Engine.pm
+++ b/lib/DBM/Deep/Engine.pm
@@ -418,9 +418,15 @@ sub write_value {
         $self->write_tag( $obj, undef, SIG_INTERNAL,pack($self->{long_pack}, $value->_base_offset) );
     }
     elsif ($r eq 'HASH') {
+        if ( tied( %{$value} ) ) {
+            $obj->_throw_error( "Cannot store something that is tied" );
+        }
         $self->write_tag( $obj, undef, SIG_HASH, chr(0)x$self->{index_size} );
     }
     elsif ($r eq 'ARRAY') {
+        if ( tied( @{$value} ) ) {
+            $obj->_throw_error( "Cannot store something that is tied" );
+        }
         $self->write_tag( $obj, undef, SIG_ARRAY, chr(0)x$self->{index_size} );
     }
     elsif (!defined($value)) {

diff --git a/t/30_already_tied.t b/t/30_already_tied.t
new file mode 100644 (file)
index 0000000..8d65829
--- /dev/null
+++ b/t/30_already_tied.t
@@ -0,0 +1,81 @@
+##
+# DBM::Deep Test
+##
+use strict;
+use Test::More tests => 7;
+use Test::Exception;
+use File::Temp qw( tempfile tempdir );
+use Fcntl qw( :flock );
+
+use_ok( 'DBM::Deep' );
+
+my $dir = tempdir( CLEANUP => 1 );
+my ($fh, $filename) = tempfile( 'tmpXXXX', UNLINK => 1, DIR => $dir );
+flock $fh, LOCK_UN;
+my $db = DBM::Deep->new( $filename );
+
+{
+    {
+        package My::Tie::Hash;
+
+        sub TIEHASH {
+            my $class = shift;
+
+            return bless {
+            }, $class;
+        }
+    }
+
+    my %hash;
+    tie %hash, 'My::Tie::Hash';
+    isa_ok( tied(%hash), 'My::Tie::Hash' );
+
+    throws_ok {
+        $db->{foo} = \%hash;
+    } qr/Cannot store something that is tied/, "Cannot store tied hashes";
+}
+
+{
+    {
+        package My::Tie::Array;
+
+        sub TIEARRAY {
+            my $class = shift;
+
+            return bless {
+            }, $class;
+        }
+
+        sub FETCHSIZE { 0 }
+    }
+
+    my @array;
+    tie @array, 'My::Tie::Array';
+    isa_ok( tied(@array), 'My::Tie::Array' );
+
+    throws_ok {
+        $db->{foo} = \@array;
+    } qr/Cannot store something that is tied/, "Cannot store tied arrays";
+}
+
+    {
+        package My::Tie::Scalar;
+
+        sub TIESCALAR {
+            my $class = shift;
+
+            return bless {
+            }, $class;
+        }
+    }
+
+    my $scalar;
+    tie $scalar, 'My::Tie::Scalar';
+    isa_ok( tied($scalar), 'My::Tie::Scalar' );
+
+TODO: {
+    local $TODO = "Scalar refs are just broked";
+    throws_ok {
+        $db->{foo} = \$scalar;
+    } qr/Cannot store something that is tied/, "Cannot store tied scalars";
+}

diff --git a/t/31_references.t b/t/31_references.t
new file mode 100644 (file)
index 0000000..7aa23c6
--- /dev/null
+++ b/t/31_references.t
@@ -0,0 +1,30 @@
+##
+# DBM::Deep Test
+##
+use strict;
+use Test::More tests => 5;
+use Test::Exception;
+use File::Temp qw( tempfile tempdir );
+use Fcntl qw( :flock );
+
+use_ok( 'DBM::Deep' );
+
+my $dir = tempdir( CLEANUP => 1 );
+my ($fh, $filename) = tempfile( 'tmpXXXX', UNLINK => 1, DIR => $dir );
+flock $fh, LOCK_UN;
+my $db = DBM::Deep->new( $filename );
+
+my %hash = (
+    foo => 1,
+    bar => [ 1 .. 3 ],
+    baz => { a => 42 },
+);
+
+$db->{hash} = \%hash;
+
+is( $db->{hash}{foo}, 1 );
+is_deeply( $db->{hash}{bar}, [ 1 .. 3 ] );
+is_deeply( $db->{hash}{baz}, { a => 42 } );
+
+$hash{foo} = 2;
+is( $db->{hash}{foo}, 2 );