191f110e0Safresh1#!./perl -w 2f3efcd01Safresh1# 3f3efcd01Safresh1# Exercise the error handling callback mechanism in gdbm. 4f3efcd01Safresh1# 5f3efcd01Safresh1# Try to trigger an error by surreptitiously closing the file handle which 6f3efcd01Safresh1# gdbm has opened. Note that this won't trigger an error in newer 7f3efcd01Safresh1# releases of the gdbm library, which uses mmap() rather than write() etc: 8f3efcd01Safresh1# so skip in that case. 9f3efcd01Safresh1 1091f110e0Safresh1use strict; 1191f110e0Safresh1 1291f110e0Safresh1use Test::More; 1391f110e0Safresh1use Config; 14*256a93a4Safresh1use File::Temp 'tempdir'; 15*256a93a4Safresh1use File::Spec; 1691f110e0Safresh1 1791f110e0Safresh1BEGIN { 1891f110e0Safresh1 plan(skip_all => "GDBM_File was not built") 1991f110e0Safresh1 unless $Config{extensions} =~ /\bGDBM_File\b/; 2091f110e0Safresh1 216fb12b70Safresh1 # https://rt.perl.org/Public/Bug/Display.html?id=117967 226fb12b70Safresh1 plan(skip_all => "GDBM_File is flaky in $^O") 236fb12b70Safresh1 if $^O =~ /darwin/; 246fb12b70Safresh1 2591f110e0Safresh1 plan(tests => 8); 2691f110e0Safresh1 use_ok('GDBM_File'); 2791f110e0Safresh1} 2891f110e0Safresh1 295759b3d2Safresh1open my $fh, '<', $^X or die "Can't open $^X: $!"; 3091f110e0Safresh1my $fileno = fileno $fh; 3191f110e0Safresh1isnt($fileno, undef, "Can find next available file descriptor"); 3291f110e0Safresh1close $fh or die $!; 3391f110e0Safresh1 3491f110e0Safresh1is((open $fh, "<&=$fileno"), undef, 3591f110e0Safresh1 "Check that we cannot open fileno $fileno. \$! is $!"); 3691f110e0Safresh1 3791f110e0Safresh1umask(0); 38*256a93a4Safresh1my $wd = tempdir(CLEANUP => 1); 3991f110e0Safresh1my %h; 40*256a93a4Safresh1isa_ok(tie(%h, 'GDBM_File', File::Spec->catfile($wd, 'fatal_dbmx'), 41*256a93a4Safresh1 GDBM_WRCREAT, 0640), 'GDBM_File'); 4291f110e0Safresh1 4391f110e0Safresh1isnt((open $fh, "<&=$fileno"), undef, "dup fileno $fileno") 4491f110e0Safresh1 or diag("\$! = $!"); 4591f110e0Safresh1isnt(close $fh, undef, 4691f110e0Safresh1 "close fileno $fileno, out from underneath the GDBM_File"); 47f3efcd01Safresh1 48f3efcd01Safresh1# store some data to a closed file handle 49f3efcd01Safresh1 50f3efcd01Safresh1my $res = eval { 5191f110e0Safresh1 $h{Perl} = 'Rules'; 5291f110e0Safresh1 untie %h; 53f3efcd01Safresh1 99; 54f3efcd01Safresh1}; 5591f110e0Safresh1 56f3efcd01Safresh1SKIP: { 57f3efcd01Safresh1 skip "Can't trigger failure", 2 if (defined $res and $res == 99); 58f3efcd01Safresh1 59f3efcd01Safresh1 is $res, undef, "eval should return undef"; 60f3efcd01Safresh1 61f3efcd01Safresh1 # Observed "File write error" and "lseek error" from two different 62f3efcd01Safresh1 # systems. So there might be more variants. Important part was that 63f3efcd01Safresh1 # we trapped the error # via croak. 6491f110e0Safresh1 like($@, qr/ at .*\bfatal\.t line \d+\.\n\z/, 6591f110e0Safresh1 'expected error message from GDBM_File'); 66f3efcd01Safresh1} 6791f110e0Safresh1 68