In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/6de2dd46140d0d3ab6813e26940d7b74418b0260?hp=eaed4a85bcd00374e80ef8f30b39495d0434407f>
- Log ----------------------------------------------------------------- commit 6de2dd46140d0d3ab6813e26940d7b74418b0260 Author: Tony Cook <[email protected]> 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 <[email protected]> ----------------------------------------------------------------------- Summary of changes: 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 be93d824a7..efe9d80479 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3450,6 +3450,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 a8f7f9ec80..0c22a756e2 100644 --- a/META.json +++ b/META.json @@ -85,6 +85,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 8cc5c5f19e..b5496d4a6b 100644 --- a/META.yml +++ b/META.yml @@ -82,6 +82,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 07a5e51cf3..a9a585269b 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 fe749a63e6..15ef9b2aee 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 0000000000..08cbe2b884 --- /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}); +} -- Perl5 Master Repository
