1#!./perl -w 2# 3# Exercise the error handling callback mechanism in gdbm. 4# 5# Try to trigger an error by surreptitiously closing the file handle which 6# gdbm has opened. Note that this won't trigger an error in newer 7# releases of the gdbm library, which uses mmap() rather than write() etc: 8# so skip in that case. 9 10use strict; 11 12use Test::More; 13use Config; 14 15BEGIN { 16 plan(skip_all => "GDBM_File was not built") 17 unless $Config{extensions} =~ /\bGDBM_File\b/; 18 19 # https://rt.perl.org/Public/Bug/Display.html?id=117967 20 plan(skip_all => "GDBM_File is flaky in $^O") 21 if $^O =~ /darwin/; 22 23 plan(tests => 8); 24 use_ok('GDBM_File'); 25} 26 27unlink <fatal_dbmx*>; 28 29open my $fh, '<', $^X or die "Can't open $^X: $!"; 30my $fileno = fileno $fh; 31isnt($fileno, undef, "Can find next available file descriptor"); 32close $fh or die $!; 33 34is((open $fh, "<&=$fileno"), undef, 35 "Check that we cannot open fileno $fileno. \$! is $!"); 36 37umask(0); 38my %h; 39isa_ok(tie(%h, 'GDBM_File', 'fatal_dbmx', GDBM_WRCREAT, 0640), 'GDBM_File'); 40 41isnt((open $fh, "<&=$fileno"), undef, "dup fileno $fileno") 42 or diag("\$! = $!"); 43isnt(close $fh, undef, 44 "close fileno $fileno, out from underneath the GDBM_File"); 45 46# store some data to a closed file handle 47 48my $res = eval { 49 $h{Perl} = 'Rules'; 50 untie %h; 51 99; 52}; 53 54SKIP: { 55 skip "Can't trigger failure", 2 if (defined $res and $res == 99); 56 57 is $res, undef, "eval should return undef"; 58 59 # Observed "File write error" and "lseek error" from two different 60 # systems. So there might be more variants. Important part was that 61 # we trapped the error # via croak. 62 like($@, qr/ at .*\bfatal\.t line \d+\.\n\z/, 63 'expected error message from GDBM_File'); 64} 65 66unlink <fatal_dbmx*>; 67