In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/76eea786714b283ffd7e4f7b662ec945fd97db68?hp=0561e60b8176e7cda2f409814c660336f3e25fb6>
- Log ----------------------------------------------------------------- commit 76eea786714b283ffd7e4f7b662ec945fd97db68 Author: David Mitchell <[email protected]> Date: Tue Oct 14 12:26:13 2014 +0100 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). M dist/threads-shared/shared.xs M dist/threads-shared/t/object2.t commit 399547d72ff67024bd23426fc6e6aa2593d47a9e Author: David Mitchell <[email protected]> Date: Mon Oct 13 12:45:14 2014 +0100 threads::shared "$#shared = N" off-by-one error RT #122950 my @a : shared; $#a = 3; # actually set it to 4 There was a simple off-by-one error in the XS code that handled the STORESIZE tie method (confusing the array size and fill, which differ by 1). Amazingly, there was no test for it, and no-one had noticed up until now. Note that this commit causes three tests in object2.t to fail: this is because fixing the $#shared bug exposed another bug that was being masked by this one. They will be fixed in the next commit M dist/threads-shared/lib/threads/shared.pm M dist/threads-shared/shared.xs M dist/threads-shared/t/av_simple.t ----------------------------------------------------------------------- Summary of changes: dist/threads-shared/lib/threads/shared.pm | 4 +-- dist/threads-shared/shared.xs | 24 +++++++++++++++-- dist/threads-shared/t/av_simple.t | 12 ++++++++- dist/threads-shared/t/object2.t | 43 ++++++++++++++++++++++++++++++- 4 files changed, 77 insertions(+), 6 deletions(-) diff --git a/dist/threads-shared/lib/threads/shared.pm b/dist/threads-shared/lib/threads/shared.pm index bad2c41..304891c 100644 --- a/dist/threads-shared/lib/threads/shared.pm +++ b/dist/threads-shared/lib/threads/shared.pm @@ -7,7 +7,7 @@ use warnings; use Scalar::Util qw(reftype refaddr blessed); -our $VERSION = '1.46'; # Please update the pod, too. +our $VERSION = '1.47'; # Please update the pod, too. my $XS_VERSION = $VERSION; $VERSION = eval $VERSION; @@ -195,7 +195,7 @@ threads::shared - Perl extension for sharing data structures between threads =head1 VERSION -This document describes threads::shared version 1.46 +This document describes threads::shared version 1.47 =head1 SYNOPSIS diff --git a/dist/threads-shared/shared.xs b/dist/threads-shared/shared.xs index f59a82a..162a3d7 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); + 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/av_simple.t b/dist/threads-shared/t/av_simple.t index 7fab9b2..305c6d5 100644 --- a/dist/threads-shared/t/av_simple.t +++ b/dist/threads-shared/t/av_simple.t @@ -27,7 +27,7 @@ sub ok { BEGIN { $| = 1; - print("1..44\n"); ### Number of tests that will be run ### + print("1..47\n"); ### Number of tests that will be run ### }; use threads; @@ -130,6 +130,16 @@ ok(37, !defined delete($foo[0]), "Check that delete works from a thread"); ok(44, is_shared(@foo), "Check for sharing"); +# RT #122950 + +@foo = ('a'..'z'); +$#foo = 2; + +ok(45, $#foo == 2, "\$#foo assignment: \$#"); +ok(46, @foo == 3, "\$#foo assignment: scalar"); +ok(47, "@foo" eq "a b c", "\$#foo assignment: array interpolation"); + + exit(0); # EOF diff --git a/dist/threads-shared/t/object2.t b/dist/threads-shared/t/object2.t index f59bad8..3d795b9 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 -- Perl5 Master Repository
