threads: $#shared = N should destroy

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).

2 files changed, 64 insertions, 3 deletions

diff --git a/dist/threads-shared/shared.xs b/dist/threads-shared/shared.xs
index 8e41139b02..162a3d7028 100644
--- a/dist/threads-shared/shared.xs
+++ b/dist/threads-shared/shared.xs
@@ -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;
 
 
diff --git a/dist/threads-shared/t/object2.t b/dist/threads-shared/t/object2.t
index f59bad8d27..3d795b9208 100644
--- a/dist/threads-shared/t/object2.t
+++ b/dist/threads-shared/t/object2.t
@@ -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