Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

[PATCH] Fix possible memory leak in IO::Poll #15640

Closed
p5pRT opened this issue Oct 2, 2016 · 14 comments
Closed

[PATCH] Fix possible memory leak in IO::Poll #15640

p5pRT opened this issue Oct 2, 2016 · 14 comments

Comments

@p5pRT
Copy link

p5pRT commented Oct 2, 2016

Migrated from rt.perl.org#129788 (status was 'resolved')

Searchable as RT129788$

@p5pRT
Copy link
Author

p5pRT commented Oct 2, 2016

From @dur-randir

Created by @dur-randir

Under some exotic circumstances IO​::Poll​::_poll() could leak memory.
Sample test case is​:

use IO​::Poll;

sub TIESCALAR { bless {} }
sub FETCH { die }

tie(my $foo, __PACKAGE__);

while (1) {
  eval { IO​::Poll​::_poll(0, 1..10_000, $foo, 1) }
}

Perl Info

Flags:
    category=library
    severity=low
    Type=Patch
    PatchStatus=HasPatch
    module=IO::Poll

Site configuration information for perl 5.22.1:

Configured by dur-randir at Mon Dec 14 02:53:24 MSK 2015.

Summary of my perl5 (revision 5 version 22 subversion 1) configuration:

  Platform:
    osname=darwin, osvers=13.4.0, archname=darwin-2level
    uname='darwin isengard.local 13.4.0 darwin kernel version 13.4.0:
wed mar 18 16:20:14 pdt 2015; root:xnu-2422.115.14~1release_x86_64
x86_64 '
    config_args='-de
-Dprefix=/Users/dur-randir/perlbrew/perls/perl-5.22.1
-Aeval:scriptdir=/Users/dur-randir/perlbrew/perls/perl-5.22.1/bin'
    hint=recommended, useposix=true, d_sigaction=define
    useithreads=undef, usemultiplicity=undef
    use64bitint=define, use64bitall=define, uselongdouble=undef
    usemymalloc=n, bincompat5005=undef
  Compiler:
    cc='cc', ccflags ='-fno-common -DPERL_DARWIN -fno-strict-aliasing
-pipe -fstack-protector -I/usr/local/include',
    optimize='-O3',
    cppflags='-fno-common -DPERL_DARWIN -fno-strict-aliasing -pipe
-fstack-protector -I/usr/local/include'
    ccversion='', gccversion='4.2.1 Compatible Apple LLVM 6.0
(clang-600.0.56)', gccosandvers=''
    intsize=4, longsize=8, ptrsize=8, doublesize=8,
byteorder=12345678, doublekind=3
    d_longlong=define, longlongsize=8, d_longdbl=define,
longdblsize=16, longdblkind=3
    ivtype='long', ivsize=8, nvtype='double', nvsize=8, Off_t='off_t',
lseeksize=8
    alignbytes=8, prototype=define
  Linker and Libraries:
    ld='env MACOSX_DEPLOYMENT_TARGET=10.3 cc', ldflags ='
-fstack-protector -L/usr/local/lib'
    libpth=/Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/bin/../lib/clang/6.0/lib
/Applications/Xcode.app/Contents/Developer/Toolchains/XcodeDefault.xctoolchain/usr/lib
/Applications/Xcode.app/Contents/Developer/Platforms/MacOSX.platform/Developer/SDKs/MacOSX10.10.sdk/usr/lib
/usr/local/lib /usr/lib
    libs=-lpthread -lgdbm -ldbm -ldl -lm -lutil -lc
    perllibs=-lpthread -ldl -lm -lutil -lc
    libc=, so=dylib, useshrplib=false, libperl=libperl.a
    gnulibc_version=''
  Dynamic Linking:
    dlsrc=dl_dlopen.xs, dlext=bundle, d_dlsymun=undef, ccdlflags=' '
    cccdlflags=' ', lddlflags=' -bundle -undefined dynamic_lookup
-L/usr/local/lib -fstack-protector'



@INC for perl 5.22.1:
    /Users/dur-randir/perlbrew/perls/perl-5.22.1/lib/site_perl/5.22.1/darwin-2level
    /Users/dur-randir/perlbrew/perls/perl-5.22.1/lib/site_perl/5.22.1
    /Users/dur-randir/perlbrew/perls/perl-5.22.1/lib/5.22.1/darwin-2level
    /Users/dur-randir/perlbrew/perls/perl-5.22.1/lib/5.22.1
    .


Environment for perl 5.22.1:
    DYLD_LIBRARY_PATH (unset)
    HOME=/Users/dur-randir
    LANG=en_US.UTF-8
    LANGUAGE (unset)
    LD_LIBRARY_PATH (unset)
    LOGDIR (unset)
    PATH=/Users/dur-randir/perlbrew/bin:/Users/dur-randir/perlbrew/perls/perl-5.22.1/bin:/usr/local/bin:/usr/local/sbin:/usr/bin:/bin:/usr/sbin:/sbin:/usr/texbin
    PERLBREW_BASHRC_VERSION=0.69
    PERLBREW_HOME=/Users/dur-randir/.perlbrew
    PERLBREW_MANPATH=/Users/dur-randir/perlbrew/perls/perl-5.22.1/man
    PERLBREW_PATH=/Users/dur-randir/perlbrew/bin:/Users/dur-randir/perlbrew/perls/perl-5.22.1/bin
    PERLBREW_PERL=perl-5.22.1
    PERLBREW_ROOT=/Users/dur-randir/perlbrew
    PERLBREW_VERSION=0.69
    PERL_BADLANG (unset)
    SHELL=/usr/local/bin/zsh

@p5pRT
Copy link
Author

p5pRT commented Oct 2, 2016

From @dur-randir

0001-IO-Poll-fix-possible-memory-leak.patch
From ab98ace745499ec49f9d20a90a9fb8e1f2f54c79 Mon Sep 17 00:00:00 2001
From: Sergey Aleynikov <sergey.aleynikov@gmail.com>
Date: Sun, 2 Oct 2016 21:50:34 +0300
Subject: [PATCH] IO::Poll: fix possible memory leak

When a magical/tied scalar which dies upon read was passed to _poll()
temporary buffer for events were not freed.
---
 dist/IO/IO.xs | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

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");
-- 
2.10.0

@p5pRT
Copy link
Author

p5pRT commented Oct 3, 2016

From @jkeenan

On Sun Oct 02 12​:54​:53 2016, randir wrote​:

This is a bug report for perl from sergey.aleynikov@​gmail.com,
generated with the help of perlbug 1.40 running under perl 5.22.1.

-----------------------------------------------------------------
[Please describe your issue here]

Under some exotic circumstances IO​::Poll​::_poll() could leak memory.
Sample test case is​:

use IO​::Poll;

sub TIESCALAR { bless {} }
sub FETCH { die }

tie(my $foo, __PACKAGE__);

while (1) {
eval { IO​::Poll​::_poll(0, 1..10_000, $foo, 1) }
}

Is there a way of converting this example into a test case, say, something that could go into dist/IO/t/io_poll.t?

Thank you very much.

--
James E Keenan (jkeenan@​cpan.org)

@p5pRT
Copy link
Author

p5pRT commented Oct 3, 2016

The RT System itself - Status changed from 'new' to 'open'

@p5pRT
Copy link
Author

p5pRT commented Oct 4, 2016

From @dur-randir

On Sun Oct 02 17​:26​:53 2016, jkeenan wrote​:

Is there a way of converting this example into a test case, say,
something that could go into dist/IO/t/io_poll.t?

Problem with leaks is that it's hard to create cross-platform test for them without accessing perl internals. I see such tests in t/op/svleak.t, but they use XS​::APItest. Is it OK to place test for a module in there?

@p5pRT
Copy link
Author

p5pRT commented Oct 5, 2016

From @cpansprout

On Tue Oct 04 12​:56​:24 2016, randir wrote​:

On Sun Oct 02 17​:26​:53 2016, jkeenan wrote​:

Is there a way of converting this example into a test case, say,
something that could go into dist/IO/t/io_poll.t?

Problem with leaks is that it's hard to create cross-platform test for
them without accessing perl internals. I see such tests in
t/op/svleak.t, but they use XS​::APItest. Is it OK to place test for a
module in there?

Since IO is built with perl that should be OK. Alternatively, you could put a test in io_poll.t that uses XS​::APItest, but make it conditional on whether XS​::APItest can load.

--

Father Chrysostomos

@p5pRT
Copy link
Author

p5pRT commented Oct 5, 2016

From @dur-randir

Here's an updated patch with a test added to t/op/svleak.t

@p5pRT
Copy link
Author

p5pRT commented Oct 5, 2016

From @dur-randir

0001-IO-Poll-fix-possible-memory-leak.patch
From 03948fa8c4c74e8dff8f23d363a5e969f9f4fac9 Mon Sep 17 00:00:00 2001
From: Sergey Aleynikov <sergey.aleynikov@gmail.com>
Date: Wed, 5 Oct 2016 21:33:38 +0300
Subject: [PATCH] IO::Poll: fix possible memory leak

Whenever a magical/tied scalar which dies upon read was passed to _poll()
temporary buffer for events was not freed.
---
 dist/IO/IO.pm |  2 +-
 dist/IO/IO.xs |  3 +--
 t/op/svleak.t | 16 +++++++++++++++-
 3 files changed, 17 insertions(+), 4 deletions(-)

diff --git a/dist/IO/IO.pm b/dist/IO/IO.pm
index 07a5e51..a9a5852 100644
--- a/dist/IO/IO.pm
+++ b/dist/IO/IO.pm
@@ -7,7 +7,7 @@ use Carp;
 use strict;
 use warnings;
 
-our $VERSION = "1.37";
+our $VERSION = "1.38";
 XSLoader::load 'IO', $VERSION;
 
 sub import {
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/t/op/svleak.t b/t/op/svleak.t
index 77ff9ae..4a0c046 100644
--- a/t/op/svleak.t
+++ b/t/op/svleak.t
@@ -15,7 +15,7 @@ BEGIN {
 
 use Config;
 
-plan tests => 138;
+plan tests => 139;
 
 # run some code N times. If the number of SVs at the end of loop N is
 # greater than (N-1)*delta at the end of loop 1, we've got a leak
@@ -560,3 +560,17 @@ EOF
     sub f { $a =~ /[^.]+$b/; }
     ::leak(2, 0, \&f, q{use re 'strict' shouldn't leak warning strings});
 }
+
+# [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.10.0

@p5pRT
Copy link
Author

p5pRT commented Oct 25, 2016

From @tonycoz

On Wed Oct 05 11​:36​:18 2016, randir wrote​:

Here's an updated patch with a test added to t/op/svleak.t

I suspect the attached is closer to what Father Chrysostomos was
after.

Tony

@p5pRT
Copy link
Author

p5pRT commented Oct 25, 2016

From @tonycoz

0001-perl-129788-IO-Poll-fix-memory-leak.patch
From 59ac1937eb4e3fcc8eb6740d2a988af339326d7f Mon Sep 17 00:00:00 2001
From: Tony Cook <tony@develop-help.com>
Date: Tue, 25 Oct 2016 16:17:18 +1100
Subject: (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>
---
 MANIFEST            |  1 +
 META.json           |  1 +
 META.yml            |  1 +
 dist/IO/IO.pm       |  2 +-
 dist/IO/IO.xs       |  3 +--
 dist/IO/t/io_leak.t | 37 +++++++++++++++++++++++++++++++++++++
 6 files changed, 42 insertions(+), 3 deletions(-)
 create mode 100644 dist/IO/t/io_leak.t

diff --git a/MANIFEST b/MANIFEST
index d2dfa4c..2f1a709 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -3412,6 +3412,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.t		See if binmode()-related methods on IO::File work
 dist/IO/t/io_file_export.t	Test IO::File exports
+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 e8aa5cb..41d44d3 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 4d43f10..95ae2bf 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.pm b/dist/IO/IO.pm
index 07a5e51..a9a5852 100644
--- a/dist/IO/IO.pm
+++ b/dist/IO/IO.pm
@@ -7,7 +7,7 @@ use Carp;
 use strict;
 use warnings;
 
-our $VERSION = "1.37";
+our $VERSION = "1.38";
 XSLoader::load 'IO', $VERSION;
 
 sub import {
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.1.4

@p5pRT
Copy link
Author

p5pRT commented Dec 7, 2016

From @tonycoz

On Mon, 24 Oct 2016 22​:22​:10 -0700, tonyc wrote​:

On Wed Oct 05 11​:36​:18 2016, randir wrote​:

Here's an updated patch with a test added to t/op/svleak.t

I suspect the attached is closer to what Father Chrysostomos was
after.

Which I've applied as 6de2dd4.

Tony

@p5pRT
Copy link
Author

p5pRT commented Dec 7, 2016

@tonycoz - Status changed from 'open' to 'pending release'

@p5pRT
Copy link
Author

p5pRT commented May 30, 2017

From @khwilliamson

Thank you for filing this report. You have helped make Perl better.

With the release today of Perl 5.26.0, this and 210 other issues have been
resolved.

Perl 5.26.0 may be downloaded via​:
https://metacpan.org/release/XSAWYERX/perl-5.26.0

If you find that the problem persists, feel free to reopen this ticket.

@p5pRT
Copy link
Author

p5pRT commented May 30, 2017

@khwilliamson - Status changed from 'pending release' to 'resolved'

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Projects
None yet
Development

No branches or pull requests

1 participant