From ceab7011c2af9d86bd7743d6c1b7c37540fe14f1 Mon Sep 17 00:00:00 2001 From: Nicholas Clark Date: Thu, 13 Dec 2012 16:38:17 +0100 Subject: [PATCH] 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. --- MANIFEST | 1 + ext/GDBM_File/GDBM_File.pm | 2 +- ext/GDBM_File/GDBM_File.xs | 7 ++++++- ext/GDBM_File/t/fatal.t | 45 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 53 insertions(+), 2 deletions(-) create mode 100644 ext/GDBM_File/t/fatal.t diff --git a/MANIFEST b/MANIFEST index a8ff0e6..7958b58 100644 --- 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 --- 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 --- 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 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 ; + +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 ; -- 2.7.4