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.
Perl · Jul 8, 2015 · c1b8440 · c1b8440
1 parent 201e9e2
commit c1b8440
Show file tree

Hide file tree

Showing 3 changed files with 29 additions and 4 deletions.
diff --git 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
@@ -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
@@ -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) {