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; 14use File::Temp 'tempdir'; 15use File::Spec; 16 17BEGIN { 18 plan(skip_all => "GDBM_File was not built") 19 unless $Config{extensions} =~ /\bGDBM_File\b/; 20 21 # https://rt.perl.org/Public/Bug/Display.html?id=117967 22 plan(skip_all => "GDBM_File is flaky in $^O") 23 if $^O =~ /darwin/; 24 25 plan(tests => 8); 26 use_ok('GDBM_File'); 27} 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 $wd = tempdir(CLEANUP => 1); 39my %h; 40isa_ok(tie(%h, 'GDBM_File', File::Spec->catfile($wd, 'fatal_dbmx'), 41 GDBM_WRCREAT, 0640), 'GDBM_File'); 42 43isnt((open $fh, "<&=$fileno"), undef, "dup fileno $fileno") 44 or diag("\$! = $!"); 45isnt(close $fh, undef, 46 "close fileno $fileno, out from underneath the GDBM_File"); 47 48# store some data to a closed file handle 49 50my $res = eval { 51 $h{Perl} = 'Rules'; 52 untie %h; 53 99; 54}; 55 56SKIP: { 57 skip "Can't trigger failure", 2 if (defined $res and $res == 99); 58 59 is $res, undef, "eval should return undef"; 60 61 # Observed "File write error" and "lseek error" from two different 62 # systems. So there might be more variants. Important part was that 63 # we trapped the error # via croak. 64 like($@, qr/ at .*\bfatal\.t line \d+\.\n\z/, 65 'expected error message from GDBM_File'); 66} 67 68