| Subject: | PATCH: memory leak when temp wrapping a named sub |
When Hook::LexWrap is used to temporarily wrap a named sub, the wrapper
is disabled rather than removed when the cleanup handle goes out of scope.
This is a big problem if code that will be called many times temporarily
wraps a sub by name. Each call will leak at least one closure, and
maybe other objects. The wrapped sub will also get slower and slower,
as each call to it must traverse a long chain of disabled wrappers.
The attached patch causes disabled wrappers around named subs to be
removed when possible.
| Subject: | hl.patch |
diff -Nurd Hook-LexWrap-0.22.orig/lib/Hook/LexWrap.pm Hook-LexWrap-0.22/lib/Hook/LexWrap.pm
--- Hook-LexWrap-0.22.orig/lib/Hook/LexWrap.pm 2008-12-18 23:49:46.000000000 +0200
+++ Hook-LexWrap-0.22/lib/Hook/LexWrap.pm 2009-10-15 09:36:26.000000000 +0200
@@ -4,6 +4,7 @@
use warnings;
our $VERSION = '0.22';
use Carp;
+use Scalar::Util qw(weaken);
{
no warnings 'redefine';
@@ -23,6 +24,9 @@
sub import { no strict 'refs'; *{caller()."::wrap"} = \&wrap }
+our %_unwrap_map;
+our $_unwrap_map_prune_countdown = 0;
+
sub wrap (*@) { ## no critic Prototypes
my ($typeglob, %wrapper) = @_;
$typeglob = (ref $typeglob || $typeglob =~ /::/)
@@ -82,7 +86,28 @@
*{$typeglob} = $imposter;
}
return unless defined wantarray;
- return bless sub{ $unwrap=1 }, 'Hook::LexWrap::Cleanup';
+ weaken(my $woriginal = $original);
+ weaken(my $wimposter = $imposter);
+ return bless sub {
+ $unwrap = 1;
+ return unless defined $woriginal;
+ return unless defined $wimposter;
+ no strict 'refs';
+ if (*{$typeglob}{CODE} eq $wimposter) {
+ while ($_unwrap_map{"$woriginal"}) {
+ $woriginal = delete $_unwrap_map{"$woriginal"};
+ }
+ *{$typeglob} = $woriginal;
+ } else {
+ if (++$_unwrap_map_prune_countdown > 100) {
+ foreach my $k (keys %_unwrap_map) {
+ defined $_unwrap_map{$k} or delete $_unwrap_map{$k};
+ }
+ $_unwrap_map_prune_countdown = 0;
+ }
+ weaken($_unwrap_map{"$wimposter"} = $woriginal);
+ }
+ }, 'Hook::LexWrap::Cleanup';
}
package Hook::LexWrap::Cleanup;
diff -Nurd Hook-LexWrap-0.22.orig/Makefile.PL Hook-LexWrap-0.22/Makefile.PL
--- Hook-LexWrap-0.22.orig/Makefile.PL 2008-11-06 13:05:25.000000000 +0200
+++ Hook-LexWrap-0.22/Makefile.PL 2009-10-15 09:31:14.000000000 +0200
@@ -10,6 +10,7 @@
ABSTRACT_FROM => 'lib/Hook/LexWrap.pm',
PL_FILES => {},
PREREQ_PM => {
+ 'Scalar::Util' => 0,
},
($ExtUtils::MakeMaker::VERSION ge '6.31'?
('LICENSE' => 'perl', ) : ()),
diff -Nurd Hook-LexWrap-0.22.orig/t/leak.t Hook-LexWrap-0.22/t/leak.t
--- Hook-LexWrap-0.22.orig/t/leak.t 1970-01-01 02:00:00.000000000 +0200
+++ Hook-LexWrap-0.22/t/leak.t 2009-10-15 10:11:26.000000000 +0200
@@ -0,0 +1,77 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Hook::LexWrap;
+
+$Foo::count = 0;
+sub Foo::new {
+ ++$Foo::count;
+ return bless {}, 'Foo';
+}
+sub Foo::DESTROY {
+ --$Foo::count;
+}
+
+# Install 4 layers of scope limited wrappers around a named sub, then delete
+# the cleanup handles (and maybe the wrapped symbol table entry) and check that
+# all the installed wrappers are cleaned up.
+# Repeat for all possible orderings of deleting the cleanup handles and
+# replacing the symbol table entry.
+
+plan tests => 6*4*3*2 * runtests_testcount();
+
+foreach my $replace_when (0, 1, 2, 3, 4, 'never') {
+ foreach my $blat1 (0, 1, 2, 3) {
+ foreach my $blat2 (0, 1, 2) {
+ foreach my $blat3 (0, 1) {
+ runtests($replace_when, $blat1, $blat2, $blat3);
+ }
+ }
+ }
+}
+
+my $wrapme_callcount = 0;
+sub wrapme_real {
+ ++$wrapme_callcount;
+}
+
+sub runtests {
+ my ($replace_when, @blat) = @_;
+ my $name = join ',', @blat, "r=$replace_when";
+
+ { no warnings 'redefine'; *wrapme = \&wrapme_real }
+ $Foo::count = $wrapme_callcount = 0;
+
+ my ($a, $b);
+ my @cleanup_handles;
+ foreach my $layer (1 .. 4) {
+ my $foo = new Foo;
+ push @cleanup_handles, wrap 'wrapme',
+ pre => sub { ++$a if $foo },
+ post => sub { ++$b if $foo };
+ }
+
+ my $glob_replaced = 0;
+ my $expect_wrapme_calls = 0;
+ foreach my $layers_installed (4, 3, 2, 1, 0) {
+ if ($replace_when eq $layers_installed) {
+ no warnings 'redefine';
+ *wrapme = sub {};
+ $glob_replaced = 1;
+ }
+ $a = $b = 0;
+ wrapme();
+ ++$expect_wrapme_calls unless $glob_replaced;
+ my $expect_prepost_calls = $glob_replaced ? 0 : $layers_installed;
+ is $a, $expect_prepost_calls, "pre sub callcount $name";
+ is $b, $expect_prepost_calls, "post sub callcount $name";
+
+ splice @cleanup_handles, shift(@blat)||0, 1 if @cleanup_handles;
+ }
+
+ is $Foo::count, 0, "no closures leaked $name";
+ is $wrapme_callcount, $expect_wrapme_calls, "wrapme callcount $name";
+}
+sub runtests_testcount { 5*2 + 2 }
+