diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | ext/GDBM_File/GDBM_File.pm | 2 | ||||
| -rw-r--r-- | ext/GDBM_File/GDBM_File.xs | 7 | ||||
| -rw-r--r-- | ext/GDBM_File/t/fatal.t | 45 |
4 files changed, 53 insertions, 2 deletions
@@ -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 a051d58902..a06fa13884 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 afb361ca97..4eb00d5e8d 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 0000000000..e15e5e2d49 --- /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*>; |