ext/GDBM_File/t/fatal.t: handle non-fatality
[perl.git] / ext / GDBM_File / t / fatal.t
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
10 use strict;
11
12 use Test::More;
13 use Config;
14
15 BEGIN {
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
27 unlink <fatal_dbmx*>;
28
29 open my $fh, '<', $^X or die "Can't open $^X: $!";
30 my $fileno = fileno $fh;
31 isnt($fileno, undef, "Can find next available file descriptor");
32 close $fh or die $!;
33
34 is((open $fh, "<&=$fileno"), undef,
35    "Check that we cannot open fileno $fileno. \$! is $!");
36
37 umask(0);
38 my %h;
39 isa_ok(tie(%h, 'GDBM_File', 'fatal_dbmx', GDBM_WRCREAT, 0640), 'GDBM_File');
40
41 isnt((open $fh, "<&=$fileno"), undef, "dup fileno $fileno")
42     or diag("\$! = $!");
43 isnt(close $fh, undef,
44      "close fileno $fileno, out from underneath the GDBM_File");
45
46 # store some data to a closed file handle
47
48 my $res = eval {
49     $h{Perl} = 'Rules';
50     untie %h;
51     99;
52 };
53
54 SKIP: {
55     skip "Can't tigger failure", 2 if $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
66 unlink <fatal_dbmx*>;