This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
threads: $#shared = N should destroy
authorDavid Mitchell <davem@iabyn.com>
Tue, 14 Oct 2014 11:26:13 +0000 (12:26 +0100)
committerDavid Mitchell <davem@iabyn.com>
Tue, 14 Oct 2014 11:33:07 +0000 (12:33 +0100)
When shrinking a shared array by setting $#shared = N,
any freed elements should trigger destructors if they are objects,
but they weren't.

This commit extends the work done by 7d585d2f3001 (which created tmp
proxys when abandoning elements of arrays and hashes) to the STORESIZE
method, which is what is triggered by $#a assignment (and indirectly by
undef @a).

dist/threads-shared/shared.xs
dist/threads-shared/t/object2.t

index 8e41139..162a3d7 100644 (file)
@@ -1371,9 +1371,29 @@ void
 STORESIZE(SV *obj,IV count)
     CODE:
         dTHXc;
-        SV *sobj = SHAREDSV_FROM_OBJ(obj);
+        SV *ssv = SHAREDSV_FROM_OBJ(obj);
+
         SHARED_EDIT;
-        av_fill((AV*) sobj, count - 1);
+        assert(SvTYPE(ssv) == SVt_PVAV);
+        if (!PL_dirty) {
+            SV **svp = AvARRAY((AV *)ssv);
+            I32 ix = AvFILLp((AV *)ssv);
+            for (;ix >= count; ix--) {
+                SV *sv = svp[ix];
+                if (!sv)
+                    continue;
+                if (   (SvOBJECT(sv) || (SvROK(sv) && (sv = SvRV(sv))))
+                    && SvREFCNT(sv) == 1 )
+                {
+                    SV *tmp = Perl_sv_newmortal(caller_perl);
+                    PERL_SET_CONTEXT((aTHX = caller_perl));
+                    sv_upgrade(tmp, SVt_RV);
+                    get_RV(tmp, sv);
+                    PERL_SET_CONTEXT((aTHX = PL_sharedsv_space));
+                }
+            }
+        }
+        av_fill((AV*) ssv, count - 1);
         SHARED_RELEASE;
 
 
index f59bad8..3d795b9 100644 (file)
@@ -17,7 +17,7 @@ use ExtUtils::testlib;
 
 BEGIN {
     $| = 1;
-    print("1..122\n");   ### Number of tests that will be run ###
+    print("1..131\n");   ### Number of tests that will be run ###
 };
 
 use threads;
@@ -406,4 +406,45 @@ ok($destroyed[$ID], 'Scalar object removed from undef shared hash');
 }
 ok($destroyed[$ID], 'Scalar object removed from shared scalar');
 
+#
+# RT #122950 abandoning array elements (e.g. by setting $#ary)
+# should trigger destructors
+
+{
+    package rt122950;
+
+    my $count = 0;
+    sub DESTROY { $count++ }
+
+    my $n = 4;
+
+    for my $type (0..1) {
+        my @a : shared;
+        $count = 0;
+        push @a, bless &threads::shared::share({}) for 1..$n;
+        for (1..$n) {
+            { # new scope to ensure tmps are freed, destructors called
+                if ($type) {
+                    pop @a;
+                }
+                else {
+                    $#a = $n - $_ - 1;
+                }
+            }
+            ::ok($count == $_,
+                "remove array object $_ by " . ($type ? "pop" : '$#a=N'));
+        }
+    }
+
+    my @a : shared;
+    $count = 0;
+    push @a, bless &threads::shared::share({}) for 1..$n;
+    {
+        undef @a; # this is implemented internally as $#a = -01
+    }
+    ::ok($count == $n, "remove array object by undef");
+}
+
+
+
 # EOF