t/27_filehandle.t

   1 use strict;
   2 use warnings FATAL => 'all';
   3
   4 use Test::More;
   5 use Test::Exception;
   6 use t::common qw( new_fh );
   7
   8 # Need to have an explicit plan in order for the sub-testing to work right.
   9 #XXX Figure out how to use subtests for that.
  10 my $pre_fork_tests = 14;
  11 plan tests => $pre_fork_tests + 2;
  12
  13 use_ok( 'DBM::Deep' );
  14
  15 {
  16     my ($fh, $filename) = new_fh();
  17
  18     # Create the datafile to be used
  19     {
  20         my $db = DBM::Deep->new( $filename );
  21         $db->{hash} = { foo => [ 'a' .. 'c' ] };
  22     }
  23
  24     {
  25         open(my $fh, '<', $filename) || die("Can't open '$filename' for reading: $!\n");
  26
  27         # test if we can open and read a db using its filehandle
  28
  29         my $db;
  30         ok( ($db = DBM::Deep->new( fh => $fh )), "open db in filehandle" );
  31         ok( $db->{hash}{foo}[1] eq 'b', "and get at stuff in the database" );
  32         throws_ok {
  33             $db->{foo} = 1;
  34         } qr/Cannot write to a readonly filehandle/, "Can't write to a read-only filehandle";
  35         ok( !$db->exists( 'foo' ), "foo doesn't exist" );
  36
  37         throws_ok {
  38             delete $db->{foo};
  39         } qr/Cannot write to a readonly filehandle/, "Can't delete from a read-only filehandle";
  40
  41         throws_ok {
  42             %$db = ();
  43         } qr/Cannot write to a readonly filehandle/, "Can't clear from a read-only filehandle";
  44
  45         SKIP: {
  46             skip( "No inode tests on Win32", 1 )
  47                 if ( $^O eq 'MSWin32' || $^O eq 'cygwin' );
  48             my $db_obj = $db->_get_self;
  49             ok( $db_obj->_engine->storage->{inode}, "The inode has been set" );
  50         }
  51
  52         close($fh);
  53     }
  54 }
  55
  56 # now the same, but with an offset into the file.  Use the database that's
  57 # embedded in the test for the DATA filehandle.  First, find the database ...
  58 {
  59     my ($fh,$filename) = new_fh();
  60
  61     print $fh "#!$^X\n";
  62     print $fh <<"__END_FH__";
  63 use strict;
  64 use Test::More 'no_plan';
  65 Test::More->builder->no_ending(1);
  66 Test::More->builder->{Curr_Test} = $pre_fork_tests;
  67
  68 use_ok( 'DBM::Deep' );
  69
  70 my \$db = DBM::Deep->new({
  71     fh => *DATA,
  72 });
  73 is(\$db->{x}, 'b', "and get at stuff in the database");
  74 __END_FH__
  75
  76     # The exec below prevents END blocks from doing this.
  77     (my $esc_dir = $t::common::dir) =~ s/(.)/sprintf "\\x{%x}", ord $1/egg;
  78     print $fh <<__END_FH_AGAIN__;
  79 use File::Path 'rmtree';
  80 rmtree "$esc_dir";
  81 __END_FH_AGAIN__
  82
  83     print $fh "__DATA__\n";
  84     close $fh;
  85
  86     my $offset = do {
  87         open my $fh, '<', $filename;
  88         while(my $line = <$fh>) {
  89             last if($line =~ /^__DATA__/);
  90         }
  91         tell($fh);
  92     };
  93
  94     {
  95         my $db = DBM::Deep->new({
  96             file        => $filename,
  97             file_offset => $offset,
  98             #XXX For some reason, this is needed to make the test pass. Figure
  99             #XXX out why later.
 100             locking => 0,
 101         });
 102
 103         $db->{x} = 'b';
 104         is( $db->{x}, 'b', 'and it was stored' );
 105     }
 106
 107     {
 108         open my $fh, '<', $filename;
 109         my $db = DBM::Deep->new({
 110             fh          => $fh,
 111             file_offset => $offset,
 112         });
 113
 114         is($db->{x}, 'b', "and get at stuff in the database");
 115
 116         ok( !$db->exists( 'foo' ), "foo doesn't exist yet" );
 117         throws_ok {
 118             $db->{foo} = 1;
 119         } qr/Cannot write to a readonly filehandle/, "Can't write to a read-only filehandle";
 120         ok( !$db->exists( 'foo' ), "foo still doesn't exist" );
 121
 122         is( $db->{x}, 'b' );
 123     }
 124
 125     exec( "$^X -Iblib/lib $filename" );
 126 }