GDBM_File is meant to croak() if the gdbm library has a fatal error.

gdbm_open() takes a fifth argument, for an optional callback function used
to report a fatal error. Since it was added in 5.000, the tied hash wrapper
implemented in GDBM_File.xs has (intended) to default this to croak().
However, the callback expects a function taking a single const char *
argument, whereas croak(const char *pat, ...) has variable arguments.
The code as-was had two bugs

1) The calling ABI on some platforms differs between a (known) variable-
   argument function, and one which takes (known) fixed arguments. As the
   call site knows the pointer is to a function with fixed arguments, the
   calling convention it uses doesn't match what Perl_croak_nocontext()
   expects, which can lead to crashes.
2) A message containing % characters will be interpreted as a printf format.

Both these are fixed by using a small station function as a wrapper, which
takes a single string argument, and passes to croak() a "%s" format string,
followed by the string for the error message.

Add a test for this functionality.

diff --git a/MANIFEST b/MANIFEST
index a8ff0e6..7958b58 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3761,6 +3761,7 @@ ext/GDBM_File/GDBM_File.pm        GDBM extension Perl module
 ext/GDBM_File/GDBM_File.xs     GDBM extension external subroutines
 ext/GDBM_File/hints/sco.pl     Hint for GDBM_File for named architecture
 ext/GDBM_File/Makefile.PL      GDBM extension makefile writer
+ext/GDBM_File/t/fatal.t                Test the fatal_func argument to gdbm_open
 ext/GDBM_File/t/gdbm.t         See if GDBM_File works
 ext/GDBM_File/typemap          GDBM extension interface types
 ext/Hash-Util/Changes          Change history of Hash::Util

diff --git a/ext/GDBM_File/GDBM_File.pm b/ext/GDBM_File/GDBM_File.pm
index a051d58..a06fa13 100644 (file)
--- a/ext/GDBM_File/GDBM_File.pm
+++ b/ext/GDBM_File/GDBM_File.pm
@@ -69,7 +69,7 @@ require XSLoader;
 );
 
 # This module isn't dual life, so no need for dev version numbers.
-$VERSION = '1.14';
+$VERSION = '1.15';
 
 XSLoader::load();
 

diff --git a/ext/GDBM_File/GDBM_File.xs b/ext/GDBM_File/GDBM_File.xs
index afb361c..4eb00d5 100644 (file)
--- a/ext/GDBM_File/GDBM_File.xs
+++ b/ext/GDBM_File/GDBM_File.xs
@@ -58,6 +58,11 @@ output_datum(pTHX_ SV *arg, char *str, int size)
 #define gdbm_setopt(db,optflag,optval,optlen) not_here("gdbm_setopt")
 #endif
 
+static void
+croak_string(const char *message) {
+    Perl_croak_nocontext("%s", message);
+}
+
 #include "const-c.inc"
 
 MODULE = GDBM_File     PACKAGE = GDBM_File     PREFIX = gdbm_
@@ -65,7 +70,7 @@ MODULE = GDBM_File    PACKAGE = GDBM_File     PREFIX = gdbm_
 INCLUDE: const-xs.inc
 
 GDBM_File
-gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak)
+gdbm_TIEHASH(dbtype, name, read_write, mode, fatal_func = (FATALFUNC)croak_string)
        char *          dbtype
        char *          name
        int             read_write

diff --git a/ext/GDBM_File/t/fatal.t b/ext/GDBM_File/t/fatal.t
new file mode 100644 (file)
index 0000000..e15e5e2
--- /dev/null
+++ b/ext/GDBM_File/t/fatal.t
@@ -0,0 +1,45 @@
+#!./perl -w
+use strict;
+
+use Test::More;
+use Config;
+
+BEGIN {
+    plan(skip_all => "GDBM_File was not built")
+       unless $Config{extensions} =~ /\bGDBM_File\b/;
+
+    plan(tests => 8);
+    use_ok('GDBM_File');
+}
+
+unlink <Op_dbmx*>;
+
+open my $fh, $^X or die "Can't open $^X: $!";
+my $fileno = fileno $fh;
+isnt($fileno, undef, "Can find next available file descriptor");
+close $fh or die $!;
+
+is((open $fh, "<&=$fileno"), undef,
+   "Check that we cannot open fileno $fileno. \$! is $!");
+
+umask(0);
+my %h;
+isa_ok(tie(%h, 'GDBM_File', 'Op_dbmx', GDBM_WRCREAT, 0640), 'GDBM_File');
+
+isnt((open $fh, "<&=$fileno"), undef, "dup fileno $fileno")
+    or diag("\$! = $!");
+isnt(close $fh, undef,
+     "close fileno $fileno, out from underneath the GDBM_File");
+is(eval {
+    $h{Perl} = 'Rules';
+    untie %h;
+    1;
+}, undef, 'Trapped error when attempting to write to knobbled GDBM_File');
+
+# Observed "File write error" and "lseek error" from two different systems.
+# So there might be more variants. Important part was that we trapped the error
+# via croak.
+like($@, qr/ at .*\bfatal\.t line \d+\.\n\z/,
+     'expected error message from GDBM_File');
+
+unlink <Op_dbmx*>;