In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/7799a2d155d76d9d2f3e851ca15261c8e22252c2?hp=cb0ee57a7d1f2e00a980be7c8e54b7b704cd764b>
- Log -----------------------------------------------------------------
commit 7799a2d155d76d9d2f3e851ca15261c8e22252c2
Merge: cb0ee57 2f9365d
Author: Tony Cook <t...@develop-help.com>
Date: Mon Jan 11 09:33:34 2016 +1100
[perl #126633] fix some corner cases in OPpASSIGN_COMMON_* handling
commit 2f9365dc3b09bdf83c00a6d176d882057608308e
Author: Dave Mitchell <da...@iabyn.com>
Date: Thu Jan 7 11:36:10 2016 +1100
[perl #126633] check children of OA_DANGEROUS ops for common scalars
Tony Cook: added tests
M op.c
M t/op/aassign.t
commit 5c1db5695506e43718a1575bebb1ecf2675e3798
Author: Tony Cook <t...@develop-help.com>
Date: Tue Dec 8 11:19:48 2015 +1100
[perl #126633] copy anything gmagical on the right
It could retrieve something we're setting on the left.
M pp_hot.c
M t/op/aassign.t
commit beb08a1e6d63c1eed4da66e066991eb58afccde7
Author: Tony Cook <t...@develop-help.com>
Date: Mon Dec 7 16:24:52 2015 +1100
[perl #126633] if we see smagic on the left copy the rest on the right
M pp_hot.c
M t/op/aassign.t
commit 0072721ceb719c27771e260b6e8516b947c4bb94
Author: Tony Cook <t...@develop-help.com>
Date: Mon Dec 7 16:22:38 2015 +1100
[perl #126633] TODO tests
M t/op/aassign.t
-----------------------------------------------------------------------
Summary of changes:
op.c | 3 ++-
pp_hot.c | 54 +++++++++++++++++++++++++++++++++---------------------
t/op/aassign.t | 48 ++++++++++++++++++++++++++++++++++++++++++++++++
3 files changed, 83 insertions(+), 22 deletions(-)
diff --git a/op.c b/op.c
index 1b78a4c..ee31adc 100644
--- a/op.c
+++ b/op.c
@@ -12343,7 +12343,8 @@ S_aassign_scan(pTHX_ OP* o, bool rhs, bool top, int
*scalars_p)
default:
if (PL_opargs[o->op_type] & OA_DANGEROUS) {
(*scalars_p) += 2;
- return AAS_DANGEROUS;
+ flags = AAS_DANGEROUS;
+ break;
}
if ( (PL_opargs[o->op_type] & OA_TARGLEX)
diff --git a/pp_hot.c b/pp_hot.c
index b29c347..b80efae 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1110,6 +1110,7 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV
**lastlelem,
SSize_t lcount = lastlelem - firstlelem + 1;
bool marked = FALSE; /* have we marked any LHS with SVf_BREAK ? */
bool const do_rc1 = cBOOL(PL_op->op_private & OPpASSIGN_COMMON_RC1);
+ bool copy_all = FALSE;
assert(!PL_in_clean_all); /* SVf_BREAK not already in use */
assert(firstlelem < lastlelem); /* at least 2 LH elements */
@@ -1138,6 +1139,9 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV
**lastlelem,
}
assert(svl);
+ if (SvSMAGICAL(svl)) {
+ copy_all = TRUE;
+ }
if (SvTYPE(svl) == SVt_PVAV || SvTYPE(svl) == SVt_PVHV) {
if (!marked)
return;
@@ -1169,7 +1173,7 @@ S_aassign_copy_common(pTHX_ SV **firstlelem, SV
**lastlelem,
svr = *relem;
assert(svr);
- if (UNLIKELY(SvFLAGS(svr) & SVf_BREAK)) {
+ if (UNLIKELY(SvFLAGS(svr) & (SVf_BREAK|SVs_GMG) || copy_all)) {
#ifdef DEBUGGING
if (fake) {
@@ -1259,29 +1263,37 @@ PP(pp_aassign)
* clobber a value on the right that's used later in the list.
*/
- if ( (PL_op->op_private & (OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1))
- /* at least 2 LH and RH elements, or commonality isn't an issue */
- && (firstlelem < lastlelem && firstrelem < lastrelem)
- ) {
- if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
- /* skip the scan if all scalars have a ref count of 1 */
- for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
- sv = *lelem;
- if (!sv || SvREFCNT(sv) == 1)
- continue;
- if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
- goto do_scan;
- break;
- }
+ /* at least 2 LH and RH elements, or commonality isn't an issue */
+ if (firstlelem < lastlelem && firstrelem < lastrelem) {
+ for (relem = firstrelem+1; relem <= lastrelem; relem++) {
+ if (SvGMAGICAL(*relem))
+ goto do_scan;
}
- else {
- do_scan:
- S_aassign_copy_common(aTHX_
- firstlelem, lastlelem, firstrelem, lastrelem
+ for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
+ if (*lelem && SvSMAGICAL(*lelem))
+ goto do_scan;
+ }
+ if ( PL_op->op_private &
(OPpASSIGN_COMMON_SCALAR|OPpASSIGN_COMMON_RC1) ) {
+ if (PL_op->op_private & OPpASSIGN_COMMON_RC1) {
+ /* skip the scan if all scalars have a ref count of 1 */
+ for (lelem = firstlelem; lelem <= lastlelem; lelem++) {
+ sv = *lelem;
+ if (!sv || SvREFCNT(sv) == 1)
+ continue;
+ if (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVAV)
+ goto do_scan;
+ break;
+ }
+ }
+ else {
+ do_scan:
+ S_aassign_copy_common(aTHX_
+ firstlelem, lastlelem, firstrelem,
lastrelem
#ifdef DEBUGGING
- , fake
+ , fake
#endif
- );
+ );
+ }
}
}
#ifdef DEBUGGING
diff --git a/t/op/aassign.t b/t/op/aassign.t
index 7b245cd..e1c687c 100644
--- a/t/op/aassign.t
+++ b/t/op/aassign.t
@@ -343,5 +343,53 @@ SKIP: {
is($y, 1, 'single scalar on RHS, but two on LHS: y');
}
+{ # magic handling, see #126633
+ use v5.22;
+ my $set;
+ package ArrayProxy {
+ sub TIEARRAY { bless [ $_[1] ] }
+ sub STORE { $_[0][0]->[$_[1]] = $_[2]; $set = 1 }
+ sub FETCH { $_[0][0]->[$_[1]] }
+ sub CLEAR { @{$_[0][0]} = () }
+ sub EXTEND {}
+ };
+ my @base = ( "a", "b" );
+ my @real = @base;
+ my @proxy;
+ my $temp;
+ tie @proxy, "ArrayProxy", \@real;
+ @proxy[0, 1] = @real[1, 0];
+ is($real[0], "b", "tied left first");
+ is($real[1], "a", "tied left second");
+ @real = @base;
+ @real[0, 1] = @proxy[1, 0];
+ is($real[0], "b", "tied right first");
+ is($real[1], "a", "tied right second");
+ @real = @base;
+ @proxy[0, 1] = @proxy[1, 0];
+ is($real[0], "b", "tied both first");
+ is($real[1], "a", "tied both second");
+ @real = @base;
+ ($temp, @real) = @proxy[1, 0];
+ is($real[0], "a", "scalar/array tied right");
+ @real = @base;
+ ($temp, @proxy) = @real[1, 0];
+ is($real[0], "a", "scalar/array tied left");
+ @real = @base;
+ ($temp, @proxy) = @proxy[1, 0];
+ is($real[0], "a", "scalar/array tied both");
+ $set = 0;
+ my $orig;
+ ($proxy[0], $orig) = (1, $set);
+ is($orig, 0, 'previous value of $set');
+
+ # from cpan #110278
+ use List::Util qw(min);
+ my $x = 1;
+ my $y = 2;
+ ( $x, $y ) = ( min($y), min($x) );
+ is($x, 2, "check swap for \$x");
+ is($y, 1, "check swap for \$y");
+}
done_testing();
--
Perl5 Master Repository
