diff options
author | Daniel Dragan <bulk88@hotmail.com> | 2015-05-10 11:36:05 -0400 |
---|---|---|
committer | Tony Cook <tony@develop-help.com> | 2015-07-08 10:25:53 +1000 |
commit | c1b8440fca7358a5c52763ce726d40026870519c (patch) | |
tree | 0b36aa45ce82a2d8259c09bc919f240fcb0a6a66 | |
parent | 201e9e2aa1088e65b7160f94706673641f1e018a (diff) | |
download | perl-c1b8440fca7358a5c52763ce726d40026870519c.tar.gz |
add test that fails for #124181 to Typemap.t
These tests will either fail with harness, and randomly SEGV for
me, which is intentional since they are testing memory
corruption.
-rw-r--r-- | ext/XS-Typemap/Typemap.pm | 4 | ||||
-rw-r--r-- | ext/XS-Typemap/Typemap.xs | 9 | ||||
-rw-r--r-- | ext/XS-Typemap/t/Typemap.t | 20 |
3 files changed, 29 insertions, 4 deletions
diff --git a/ext/XS-Typemap/Typemap.pm b/ext/XS-Typemap/Typemap.pm index de3319b059..a1ae0211d2 100644 --- a/ext/XS-Typemap/Typemap.pm +++ b/ext/XS-Typemap/Typemap.pm @@ -36,7 +36,7 @@ require XSLoader; use vars qw/ $VERSION @EXPORT /; -$VERSION = '0.13'; +$VERSION = '0.14'; @EXPORT = (qw/ T_SV @@ -76,7 +76,7 @@ $VERSION = '0.13'; T_OPAQUEPTR_IN T_OPAQUEPTR_OUT T_OPAQUEPTR_OUT_short T_OPAQUEPTR_IN_struct T_OPAQUEPTR_OUT_struct T_ARRAY - T_STDIO_open T_STDIO_close T_STDIO_print + T_STDIO_open T_STDIO_open_ret_in_arg T_STDIO_close T_STDIO_print T_PACKED_in T_PACKED_out T_PACKEDARRAY_in T_PACKEDARRAY_out T_INOUT T_IN T_OUT diff --git a/ext/XS-Typemap/Typemap.xs b/ext/XS-Typemap/Typemap.xs index 3fa0e74abc..8314cc2b04 100644 --- a/ext/XS-Typemap/Typemap.xs +++ b/ext/XS-Typemap/Typemap.xs @@ -906,6 +906,15 @@ T_STDIO_open( file ) OUTPUT: RETVAL +void +T_STDIO_open_ret_in_arg( file, io) + const char * file + FILE * io = NO_INIT + CODE: + io = xsfopen( file ); + OUTPUT: + io + SysRet T_STDIO_close( f ) PerlIO * f diff --git a/ext/XS-Typemap/t/Typemap.t b/ext/XS-Typemap/t/Typemap.t index 27b40860fd..49ac479884 100644 --- a/ext/XS-Typemap/t/Typemap.t +++ b/ext/XS-Typemap/t/Typemap.t @@ -6,10 +6,11 @@ BEGIN { } } -use Test::More tests => 152; +use Test::More tests => 156; use strict; -use warnings; +#catch WARN_INTERNAL type errors, and anything else unexpected +use warnings FATAL => 'all'; use XS::Typemap; pass(); @@ -213,6 +214,7 @@ is( T_PV("a string"), "a string"); is( T_PV(52), 52); ok !defined T_PV_null, 'RETVAL = NULL returns undef for char*'; { + use warnings NONFATAL => 'all'; my $uninit; local $SIG{__WARN__} = sub { ++$uninit if shift =~ /uninit/ }; () = ''.T_PV_null; @@ -393,6 +395,16 @@ if (defined $fh) { } } +$fh = "FOO"; +T_STDIO_open_ret_in_arg( $testfile, $fh); +ok( $fh ne "FOO", 'return io in arg open succeeds'); +ok( print($fh "first line\n"), 'can print to return io in arg'); +ok( close($fh), 'can close return io in arg'); +$fh = "FOO"; +#now with a bad file name to make sure $fh is written to on failure +T_STDIO_open_ret_in_arg( "", $fh); +ok( !defined$fh, 'return io in arg open failed successfully'); + # T_INOUT note("T_INOUT"); SCOPE: { @@ -439,6 +451,10 @@ SCOPE: { ok(!close $fh2); } +# Perl RT #124181 SEGV due to double free in typemap +# "Attempt to free unreferenced scalar" +%{*{main::XS::}{HASH}} = (); + sub is_approx { my ($l, $r, $n) = @_; if (not defined $l or not defined $r) { |