-##
-# DBM::Deep Test
-##
use strict;
-use Test::More tests => 11;
+use warnings FATAL => 'all';
+
+use Test::More;
use Test::Exception;
use t::common qw( new_fh );
-use_ok( 'DBM::Deep' );
-
-my ($fh, $filename) = new_fh();
+# Need to have an explicit plan in order for the sub-testing to work right.
+#XXX Figure out how to use subtests for that.
+my $pre_fork_tests = 14;
+plan tests => $pre_fork_tests + 2;
-# Create the datafile to be used
-{
- my $db = DBM::Deep->new( $filename );
- $db->{hash} = { foo => [ 'a' .. 'c' ] };
-}
+use_ok( 'DBM::Deep' );
{
- open(FILE, $filename) || die("Can't open '$filename' for reading: $!\n");
-
- my $db;
-
- # test if we can open and read a db using its filehandle
-
- ok(($db = DBM::Deep->new(fh => *FILE)), "open db in filehandle");
- ok($db->{hash}->{foo}->[1] eq 'b', "and get at stuff in the database");
- throws_ok {
- $db->{foo} = 1;
- } qr/Cannot write to a readonly filehandle/,
- "Can't write to a read-only filehandle";
- ok( !$db->exists( 'foo' ), "foo doesn't exist" );
-
- my $db_obj = $db->_get_self;
- ok( $db_obj->_root->{inode}, "The inode has been set" );
-
- close(FILE);
+ my ($fh, $filename) = new_fh();
+
+ # Create the datafile to be used
+ {
+ my $db = DBM::Deep->new( $filename );
+ $db->{hash} = { foo => [ 'a' .. 'c' ] };
+ }
+
+ {
+ open(my $fh, '<', $filename) || die("Can't open '$filename' for reading: $!\n");
+
+ # test if we can open and read a db using its filehandle
+
+ my $db;
+ ok( ($db = DBM::Deep->new( fh => $fh )), "open db in filehandle" );
+ ok( $db->{hash}{foo}[1] eq 'b', "and get at stuff in the database" );
+ throws_ok {
+ $db->{foo} = 1;
+ } qr/Cannot write to a readonly filehandle/, "Can't write to a read-only filehandle";
+ ok( !$db->exists( 'foo' ), "foo doesn't exist" );
+
+ throws_ok {
+ delete $db->{foo};
+ } qr/Cannot write to a readonly filehandle/, "Can't delete from a read-only filehandle";
+
+ throws_ok {
+ %$db = ();
+ } qr/Cannot write to a readonly filehandle/, "Can't clear from a read-only filehandle";
+
+ SKIP: {
+ skip( "No inode tests on Win32", 1 )
+ if ( $^O eq 'MSWin32' || $^O eq 'cygwin' );
+ my $db_obj = $db->_get_self;
+ ok( $db_obj->_engine->storage->{inode}, "The inode has been set" );
+ }
+
+ close($fh);
+ }
}
# now the same, but with an offset into the file. Use the database that's
# embedded in the test for the DATA filehandle. First, find the database ...
-open(FILE, "t/28_DATA.t") || die("Can't open t/28_DATA.t\n");
-while(my $line = <FILE>) {
- last if($line =~ /^__DATA__/);
-}
-my $offset = tell(FILE);
-close(FILE);
-
-SKIP: {
- skip "File header and format changed ... gah!", 5;
- open(FILE, "t/28_DATA.t");
-
- my $db;
-
- ok(($db = DBM::Deep->new(fh => *FILE, file_offset => $offset)), "open db in filehandle with offset");
+{
+ my ($fh,$filename) = new_fh();
- ok($db->{hash}->{foo}->[1] eq 'b', "and get at stuff in the database");
+ print $fh "#!$^X\n";
+ print $fh <<"__END_FH__";
+use strict;
+use Test::More 'no_plan';
+Test::More->builder->no_ending(1);
+Test::More->builder->{Curr_Test} = $pre_fork_tests;
- ok( !$db->exists( 'foo' ), "foo doesn't exist yet" );
- throws_ok {
- $db->{foo} = 1;
- } qr/Cannot write to a readonly filehandle/, "Can't write to a read-only filehandle";
- ok( !$db->exists( 'foo' ), "foo doesn't exist" );
+use_ok( 'DBM::Deep' );
- close FILE;
+my \$db = DBM::Deep->new({
+ fh => *DATA,
+});
+is(\$db->{x}, 'b', "and get at stuff in the database");
+__END_FH__
+
+ # The exec below prevents END blocks from doing this.
+ (my $esc_dir = $t::common::dir) =~ s/(.)/sprintf "\\x{%x}", ord $1/egg;
+ print $fh <<__END_FH_AGAIN__;
+use File::Path 'rmtree';
+rmtree "$esc_dir";
+__END_FH_AGAIN__
+
+ print $fh "__DATA__\n";
+ close $fh;
+
+ my $offset = do {
+ open my $fh, '<', $filename;
+ while(my $line = <$fh>) {
+ last if($line =~ /^__DATA__/);
+ }
+ tell($fh);
+ };
+
+ {
+ my $db = DBM::Deep->new({
+ file => $filename,
+ file_offset => $offset,
+ #XXX For some reason, this is needed to make the test pass. Figure
+ #XXX out why later.
+ locking => 0,
+ });
+
+ $db->{x} = 'b';
+ is( $db->{x}, 'b', 'and it was stored' );
+ }
+
+ {
+ open my $fh, '<', $filename;
+ my $db = DBM::Deep->new({
+ fh => $fh,
+ file_offset => $offset,
+ });
+
+ is($db->{x}, 'b', "and get at stuff in the database");
+
+ ok( !$db->exists( 'foo' ), "foo doesn't exist yet" );
+ throws_ok {
+ $db->{foo} = 1;
+ } qr/Cannot write to a readonly filehandle/, "Can't write to a read-only filehandle";
+ ok( !$db->exists( 'foo' ), "foo still doesn't exist" );
+
+ is( $db->{x}, 'b' );
+ }
+
+ exec( "$^X -Iblib/lib $filename" );
}