perl/perl-5.24.0-perl-129788-IO-Poll-fix-memory-leak.patch

From 478d23ef9e7700e20a75907648dd4c53b1b4f544 Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Tue, 25 Oct 2016 16:17:18 +1100
Subject: [PATCH] (perl #129788) IO::Poll: fix memory leak
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

Petr Pisar: Ported to 5.24.0:

commit 6de2dd46140d0d3ab6813e26940d7b74418b0260
Author: Tony Cook <tony@develop-help.com>
Date:   Tue Oct 25 16:17:18 2016 +1100

    (perl #129788) IO::Poll: fix memory leak

    Whenever a magical/tied scalar which dies upon read was passed to _poll()
    temporary buffer for events was not freed.

    Adapted from a patch by Sergey Aleynikov <sergey.aleynikov@gmail.com>

Signed-off-by: Petr Písař <ppisar@redhat.com>
---
 MANIFEST            |  1 +
 META.json           |  1 +
 META.yml            |  1 +
 dist/IO/IO.xs       |  3 +--
 dist/IO/t/io_leak.t | 37 +++++++++++++++++++++++++++++++++++++
 5 files changed, 41 insertions(+), 2 deletions(-)
 create mode 100644 dist/IO/t/io_leak.t

diff --git a/MANIFEST b/MANIFEST
index 2cdf616..3b5f8fb 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3228,6 +3228,7 @@ dist/IO/t/io_dir.t		See if directory-related methods from IO work
 dist/IO/t/io_dup.t		See if dup()-related methods from IO work
 dist/IO/t/io_file_export.t	Test IO::File exports
 dist/IO/t/io_file.t		See if binmode()-related methods on IO::File work
+dist/IO/t/io_leak.t		See if IO leaks SVs (only run in core)
 dist/IO/t/io_linenum.t		See if I/O line numbers are tracked correctly
 dist/IO/t/io_multihomed.t	See if INET sockets work with multi-homed hosts
 dist/IO/t/io_pipe.t		See if pipe()-related methods from IO work
diff --git a/META.json b/META.json
index 4cb21a9..2809b58 100644
--- a/META.json
+++ b/META.json
@@ -84,6 +84,7 @@
          "dist/IO/t/io_dup.t",
          "dist/IO/t/io_file.t",
          "dist/IO/t/io_file_export.t",
+         "dist/IO/t/io_leak.t",
          "dist/IO/t/io_linenum.t",
          "dist/IO/t/io_multihomed.t",
          "dist/IO/t/io_pipe.t",
diff --git a/META.yml b/META.yml
index 13a2bb3..7494d2a 100644
--- a/META.yml
+++ b/META.yml
@@ -81,6 +81,7 @@ no_index:
     - dist/IO/t/io_dup.t
     - dist/IO/t/io_file.t
     - dist/IO/t/io_file_export.t
+    - dist/IO/t/io_leak.t
     - dist/IO/t/io_linenum.t
     - dist/IO/t/io_multihomed.t
     - dist/IO/t/io_pipe.t
diff --git a/dist/IO/IO.xs b/dist/IO/IO.xs
index fe749a6..15ef9b2 100644
--- a/dist/IO/IO.xs
+++ b/dist/IO/IO.xs
@@ -318,7 +318,7 @@ PPCODE:
 {
 #ifdef HAS_POLL
     const int nfd = (items - 1) / 2;
-    SV *tmpsv = NEWSV(999,nfd * sizeof(struct pollfd));
+    SV *tmpsv = sv_2mortal(NEWSV(999,nfd * sizeof(struct pollfd)));
     /* We should pass _some_ valid pointer even if nfd is zero, but it
      * doesn't matter what it is, since we're telling it to not check any fds.
      */
@@ -337,7 +337,6 @@ PPCODE:
 	    sv_setiv(ST(i), fds[j].revents); i++;
 	}
     }
-    SvREFCNT_dec(tmpsv);
     XSRETURN_IV(ret);
 #else
 	not_here("IO::Poll::poll");
diff --git a/dist/IO/t/io_leak.t b/dist/IO/t/io_leak.t
new file mode 100644
index 0000000..08cbe2b
--- /dev/null
+++ b/dist/IO/t/io_leak.t
@@ -0,0 +1,37 @@
+#!/usr/bin/perl
+
+use warnings;
+use strict;
+
+use Test::More;
+
+eval { require XS::APItest; XS::APItest->import('sv_count'); 1 }
+  or plan skip_all => "No XS::APItest::sv_count() available";
+
+plan tests => 1;
+
+sub leak {
+    my ($n, $delta, $code, $name) = @_;
+    my $sv0 = 0;
+    my $sv1 = 0;
+    for my $i (1..$n) {
+	&$code();
+	$sv1 = sv_count();
+	$sv0 = $sv1 if $i == 1;
+    }
+    cmp_ok($sv1-$sv0, '<=', ($n-1)*$delta, $name);
+}
+
+# [perl #129788] IO::Poll shouldn't leak on errors
+{
+    package io_poll_leak;
+    use IO::Poll;
+
+    sub TIESCALAR { bless {} }
+    sub FETCH { die }
+
+    tie(my $a, __PACKAGE__);
+    sub f {eval { IO::Poll::_poll(0, $a, 1) }}
+
+    ::leak(5, 0, \&f, q{IO::Poll::_poll shouldn't leak});
+}
-- 
2.7.4