From: Vincent Pit Date: Sun, 28 Dec 2008 14:08:05 +0000 (+0100) Subject: On scope end, delete localized array elements that should not exist anymore, so that... X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4ad10a0b60fb728d1be0a9eeb1970166a3846d38;p=p5sagit%2Fp5-mst-13.2.git On scope end, delete localized array elements that should not exist anymore, so that the array recovers its previous length. Honour EXISTS and DELETE for tied arrays. --- diff --git a/pp.c b/pp.c index bdbe010..aacb789 100644 --- a/pp.c +++ b/pp.c @@ -3912,7 +3912,17 @@ PP(pp_aslice) if (SvTYPE(av) == SVt_PVAV) { const I32 arybase = CopARYBASE_get(PL_curcop); - if (lval && PL_op->op_private & OPpLVAL_INTRO) { + const bool localizing = PL_op->op_private & OPpLVAL_INTRO; + bool can_preserve = FALSE; + + if (localizing) { + MAGIC *mg; + HV *stash; + + can_preserve = SvCANEXISTDELETE(av); + } + + if (lval && localizing) { register SV **svp; I32 max = -1; for (svp = MARK + 1; svp <= SP; svp++) { @@ -3923,18 +3933,32 @@ PP(pp_aslice) if (max > AvMAX(av)) av_extend(av, max); } + while (++MARK <= SP) { register SV **svp; I32 elem = SvIV(*MARK); + bool preeminent = TRUE; if (elem > 0) elem -= arybase; + if (localizing && can_preserve) { + /* If we can determine whether the element exist, + * Try to preserve the existenceness of a tied array + * element by using EXISTS and DELETE if possible. + * Fallback to FETCH and STORE otherwise. */ + preeminent = av_exists(av, elem); + } + svp = av_fetch(av, elem, lval); if (lval) { if (!svp || *svp == &PL_sv_undef) DIE(aTHX_ PL_no_aelem, elem); - if (PL_op->op_private & OPpLVAL_INTRO) - save_aelem(av, elem, svp); + if (localizing) { + if (preeminent) + save_aelem(av, elem, svp); + else + SAVEADELETE(av, elem); + } } *MARK = svp ? *svp : &PL_sv_undef; } diff --git a/pp_hot.c b/pp_hot.c index 88fe838..66c36cb 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -2913,6 +2913,8 @@ PP(pp_aelem) AV *const av = MUTABLE_AV(POPs); const U32 lval = PL_op->op_flags & OPf_MOD || LVRET; const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av)); + const bool localizing = PL_op->op_private & OPpLVAL_INTRO; + bool preeminent = TRUE; SV *sv; if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)) @@ -2923,6 +2925,19 @@ PP(pp_aelem) elem -= CopARYBASE_get(PL_curcop); if (SvTYPE(av) != SVt_PVAV) RETPUSHUNDEF; + + if (localizing) { + MAGIC *mg; + HV *stash; + + /* If we can determine whether the element exist, + * Try to preserve the existenceness of a tied array + * element by using EXISTS and DELETE if possible. + * Fallback to FETCH and STORE otherwise. */ + if (SvCANEXISTDELETE(av)) + preeminent = av_exists(av, elem); + } + svp = av_fetch(av, elem, lval && !defer); if (lval) { #ifdef PERL_MALLOC_WRAP @@ -2952,8 +2967,12 @@ PP(pp_aelem) PUSHs(lv); RETURN; } - if (PL_op->op_private & OPpLVAL_INTRO) - save_aelem(av, elem, svp); + if (localizing) { + if (preeminent) + save_aelem(av, elem, svp); + else + SAVEADELETE(av, elem); + } else if (PL_op->op_private & OPpDEREF) vivify_ref(*svp, PL_op->op_private & OPpDEREF); } diff --git a/t/op/local.t b/t/op/local.t index 5bf56af..24acbff 100755 --- a/t/op/local.t +++ b/t/op/local.t @@ -5,7 +5,7 @@ BEGIN { @INC = qw(. ../lib); require './test.pl'; } -plan tests => 123; +plan tests => 183; my $list_assignment_supported = 1; @@ -96,6 +96,58 @@ ok(!defined $a[0]); @a = ('a', 'b', 'c'); { + local($a[4]) = 'x'; + ok(!defined $a[3]); + is($a[4], 'x'); +} +is(scalar(@a), 3); +ok(!exists $a[3]); +ok(!exists $a[4]); + +@a = ('a', 'b', 'c'); +{ + local($a[5]) = 'z'; + $a[4] = 'y'; + ok(!defined $a[3]); + is($a[4], 'y'); + is($a[5], 'z'); +} +is(scalar(@a), 5); +ok(!defined $a[3]); +is($a[4], 'y'); +ok(!exists $a[5]); + +@a = ('a', 'b', 'c'); +{ + local(@a[4,6]) = ('x', 'z'); + ok(!defined $a[3]); + is($a[4], 'x'); + ok(!defined $a[5]); + is($a[6], 'z'); +} +is(scalar(@a), 3); +ok(!exists $a[3]); +ok(!exists $a[4]); +ok(!exists $a[5]); +ok(!exists $a[6]); + +@a = ('a', 'b', 'c'); +{ + local(@a[4,6]) = ('x', 'z'); + $a[5] = 'y'; + ok(!defined $a[3]); + is($a[4], 'x'); + is($a[5], 'y'); + is($a[6], 'z'); +} +is(scalar(@a), 6); +ok(!defined $a[3]); +ok(!defined $a[4]); +is($a[5], 'y'); +ok(!exists $a[6]); + +@a = ('a', 'b', 'c'); +{ local($a[1]) = "X"; shift @a; } @@ -145,6 +197,8 @@ is($m, 5); sub TIEARRAY { bless [], $_[0] } sub STORE { print "# STORE [@_]\n"; $_[0]->[$_[1]] = $_[2] } sub FETCH { my $v = $_[0]->[$_[1]]; print "# FETCH [@_=$v]\n"; $v } + sub EXISTS { print "# EXISTS [@_]\n"; exists $_[0]->[$_[1]]; } + sub DELETE { print "# DELETE [@_]\n"; delete $_[0]->[$_[1]]; } sub CLEAR { print "# CLEAR [@_]\n"; @{$_[0]} = (); } sub FETCHSIZE { scalar(@{$_[0]}) } sub SHIFT { shift (@{$_[0]}) } @@ -169,6 +223,60 @@ ok(!defined $a[0]); is("@a", $d); } +# local() should preserve the existenceness of tied array elements +@a = ('a', 'b', 'c'); +{ + local($a[4]) = 'x'; + ok(!defined $a[3]); + is($a[4], 'x'); +} +is(scalar(@a), 3); +ok(!exists $a[3]); +ok(!exists $a[4]); + +@a = ('a', 'b', 'c'); +{ + local($a[5]) = 'z'; + $a[4] = 'y'; + ok(!defined $a[3]); + is($a[4], 'y'); + is($a[5], 'z'); +} +is(scalar(@a), 5); +ok(!defined $a[3]); +is($a[4], 'y'); +ok(!exists $a[5]); + +@a = ('a', 'b', 'c'); +{ + local(@a[4,6]) = ('x', 'z'); + ok(!defined $a[3]); + is($a[4], 'x'); + ok(!defined $a[5]); + is($a[6], 'z'); +} +is(scalar(@a), 3); +ok(!exists $a[3]); +ok(!exists $a[4]); +ok(!exists $a[5]); +ok(!exists $a[6]); + +@a = ('a', 'b', 'c'); +{ + local(@a[4,6]) = ('x', 'z'); + $a[5] = 'y'; + ok(!defined $a[3]); + is($a[4], 'x'); + is($a[5], 'y'); + is($a[6], 'z'); +} +is(scalar(@a), 6); +ok(!defined $a[3]); +ok(!defined $a[4]); +is($a[5], 'y'); +ok(!exists $a[6]); + +# see if localization works on tied hashes { package TH; sub TIEHASH { bless {}, $_[0] } @@ -181,7 +289,6 @@ ok(!defined $a[0]); sub NEXTKEY { print "# NEXTKEY [@_]\n"; each %{$_[0]} } } -# see if localization works on tied hashes tie %h, 'TH'; %h = ('a' => 1, 'b' => 2, 'c' => 3);