[perl #118829] Memory leaks in STORABLE_attach

diff --git a/MANIFEST b/MANIFEST
index 2ac0992..bb086c8 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -3332,6 +3332,7 @@ dist/Storable/t/HAS_OVERLOAD.pm           For auto-requiring of mdoules for overload
 dist/Storable/t/integer.t              See if Storable works
 dist/Storable/t/interwork56.t          Test compatibility kludge for 64bit data under 5.6.x
 dist/Storable/t/just_plain_nasty.t     See if Storable works
+dist/Storable/t/leaks.t                        See if Storable leaks (skips in core)
 dist/Storable/t/lock.t                 See if Storable works
 dist/Storable/t/make_56_interwork.pl   Make test data for interwork56.t
 dist/Storable/t/make_downgrade.pl      Make test data for downgrade.t

diff --git a/dist/Storable/Storable.pm b/dist/Storable/Storable.pm
index 1a73c3f..5f63871 100644 (file)
--- a/dist/Storable/Storable.pm
+++ b/dist/Storable/Storable.pm
@@ -21,7 +21,7 @@ package Storable; @ISA = qw(Exporter);
 
 use vars qw($canonical $forgive_me $VERSION);
 
-$VERSION = '2.43';
+$VERSION = '2.44';
 
 BEGIN {
     if (eval { local $SIG{__DIE__}; require Log::Agent; 1 }) {

diff --git a/dist/Storable/Storable.xs b/dist/Storable/Storable.xs
index 08641cd..81c8576 100644 (file)
--- a/dist/Storable/Storable.xs
+++ b/dist/Storable/Storable.xs
@@ -4247,14 +4247,29 @@ static SV *retrieve_hook(pTHX_ stcxt_t *cxt, const char *cname)
            AvARRAY(av)[0] = SvREFCNT_inc(frozen);
            rv = newSVpv(classname, 0);
            attached = scalar_call(aTHX_ rv, attach_hook, clone, av, G_SCALAR);
+           /* Free memory after a call */
+           SvREFCNT_dec(rv);
+           SvREFCNT_dec(frozen);
+           av_undef(av);
+           sv_free((SV *) av);
+           SvREFCNT_dec(attach_hook);
            if (attached &&
                SvROK(attached) && 
                sv_derived_from(attached, classname)
         ) {
                UNSEE();
-               SEEN(SvRV(attached), 0, 0);
-               return SvRV(attached);
-        }
+               /* refcnt of unneeded sv is 2 at this point (one from newHV, second from SEEN call) */
+               SvREFCNT_dec(sv);
+               SvREFCNT_dec(sv);
+               /* we need to free RV but preserve value that RV point to */
+               sv = SvRV(attached);
+               SEEN(sv, 0, 0);
+               SvRV_set(attached, NULL);
+               SvREFCNT_dec(attached);
+               if (!(flags & SHF_IDX_CLASSNAME) && classname != buf)
+                   Safefree(classname);
+               return sv;
+           }
            CROAK(("STORABLE_attach did not return a %s object", classname));
        }
 

diff --git a/dist/Storable/t/leaks.t b/dist/Storable/t/leaks.t
new file mode 100644 (file)
index 0000000..06360d6
--- /dev/null
+++ b/dist/Storable/t/leaks.t
@@ -0,0 +1,34 @@
+#!./perl
+
+use Test::More;
+use Storable ();
+BEGIN {
+eval "use Test::LeakTrace";
+plan 'skip_all' => 'Test::LeakTrace required for this tests' if $@;
+}
+plan 'tests' => 1;
+
+{
+    my $c = My::Simple->new;
+    my $d;
+    my $freezed = Storable::freeze($c);
+    no_leaks_ok
+    {
+        $d = Storable::thaw($freezed);
+        undef $d;
+    };
+
+    package My::Simple;
+    sub new {
+        my ($class, $arg) = @_;
+        bless {t=>$arg}, $class;
+    }
+    sub STORABLE_freeze {
+        return "abcderfgh";
+    }
+    sub STORABLE_attach {
+        my ($class, $c, $serialized) = @_;
+        return $class->new($serialized);
+    }
+}
+