From bbfdc870734e1313430ade6e6bd6d8ee2b720413 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Tue, 16 Jul 2013 22:56:44 -0700 Subject: [PATCH] [perl #118691] Allow defelem magic with neg indices MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit When a nonexistent array element is passed to a subroutine, a special ‘deferred element’ scalar (implemented using something called defelem magic) is passed to the subroutine instead, which delegates to the array element. This allows some_benign_function($array[$nonexistent]) to avoid autovivifying unnecessarily. Whether this magic would be triggered was based on whether the element was within the range 0..$#array. Since arrays can contain nonexistent elements before $#array, this logic is incorrect. It also makes sense to allow $array[$neg] where the negative number points before the beginning of the array to create a deferred element and only croak if it is assigned to. This commit fixes the logic for when deferred elements are created and implements these deferred negative elements. Since we have to be able to store negative values in xlv_targoff, it is convenient to make it a union (with two types--signed and unsigned) and use LvSTARGOFF for defelem array indices. --- mg.c | 14 ++++++++------ pp_hot.c | 10 ++++++++-- sv.h | 8 +++++++- t/op/array.t | 22 +++++++++++++++++++++- 4 files changed, 44 insertions(+), 10 deletions(-) diff --git a/mg.c b/mg.c index 57411810af47..5403f67dfd34 100644 --- a/mg.c +++ b/mg.c @@ -2316,10 +2316,10 @@ Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg) if (he) targ = HeVAL(he); } - else { + else if (LvSTARGOFF(sv) >= 0) { AV *const av = MUTABLE_AV(LvTARG(sv)); - if ((I32)LvTARGOFF(sv) <= AvFILL(av)) - targ = AvARRAY(av)[LvTARGOFF(sv)]; + if (LvSTARGOFF(sv) <= AvFILL(av)) + targ = AvARRAY(av)[LvSTARGOFF(sv)]; } if (targ && (targ != &PL_sv_undef)) { /* somebody else defined it for us */ @@ -2378,14 +2378,16 @@ Perl_vivify_defelem(pTHX_ SV *sv) if (!value || value == &PL_sv_undef) Perl_croak(aTHX_ PL_no_helem_sv, SVfARG(mg->mg_obj)); } + else if (LvSTARGOFF(sv) < 0) + Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv)); else { AV *const av = MUTABLE_AV(LvTARG(sv)); - if ((I32)LvTARGLEN(sv) < 0 && (I32)LvTARGOFF(sv) > AvFILL(av)) + if ((I32)LvTARGLEN(sv) < 0 && LvSTARGOFF(sv) > AvFILL(av)) LvTARG(sv) = NULL; /* array can't be extended */ else { - SV* const * const svp = av_fetch(av, LvTARGOFF(sv), TRUE); + SV* const * const svp = av_fetch(av, LvSTARGOFF(sv), TRUE); if (!svp || (value = *svp) == &PL_sv_undef) - Perl_croak(aTHX_ PL_no_aelem, (I32)LvTARGOFF(sv)); + Perl_croak(aTHX_ PL_no_aelem, LvSTARGOFF(sv)); } } SvREFCNT_inc_simple_void(value); diff --git a/pp_hot.c b/pp_hot.c index 58a30831d803..571cd63b0afa 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -2795,7 +2795,7 @@ PP(pp_aelem) IV elem = SvIV(elemsv); 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 U32 defer = PL_op->op_private & OPpLVAL_DEFER; const bool localizing = PL_op->op_private & OPpLVAL_INTRO; bool preeminent = TRUE; SV *sv; @@ -2836,14 +2836,20 @@ PP(pp_aelem) #endif if (!svp || !*svp) { SV* lv; + IV len; if (!defer) DIE(aTHX_ PL_no_aelem, elem); + len = av_len(av); lv = sv_newmortal(); sv_upgrade(lv, SVt_PVLV); LvTYPE(lv) = 'y'; sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0); LvTARG(lv) = SvREFCNT_inc_simple(av); - LvTARGOFF(lv) = elem; + /* Resolve a negative index now, unless it points before the + beginning of the array, in which case record it for error + reporting in magic_setdefelem. */ + LvSTARGOFF(lv) = + elem < 0 && len + elem >= 0 ? len + elem : elem; LvTARGLEN(lv) = 1; PUSHs(lv); RETURN; diff --git a/sv.h b/sv.h index cd15924ad2ad..6d8a40e8f6e8 100644 --- a/sv.h +++ b/sv.h @@ -528,7 +528,10 @@ struct xpvlv { _XPV_HEAD; union _xivu xiv_u; union _xnvu xnv_u; - STRLEN xlv_targoff; + union { + STRLEN xlvu_targoff; + SSize_t xlvu_stargoff; + } xlv_targoff_u; STRLEN xlv_targlen; SV* xlv_targ; char xlv_type; /* k=keys .=pos x=substr v=vec /=join/re @@ -536,6 +539,8 @@ struct xpvlv { char xlv_flags; /* 1 = negative offset 2 = negative len */ }; +#define xlv_targoff xlv_targoff_u.xlvu_targoff + struct xpvinvlist { _XPV_HEAD; IV prev_index; @@ -1403,6 +1408,7 @@ sv_force_normal does nothing. #define LvTYPE(sv) ((XPVLV*) SvANY(sv))->xlv_type #define LvTARG(sv) ((XPVLV*) SvANY(sv))->xlv_targ #define LvTARGOFF(sv) ((XPVLV*) SvANY(sv))->xlv_targoff +#define LvSTARGOFF(sv) ((XPVLV*) SvANY(sv))->xlv_targoff_u.xlvu_stargoff #define LvTARGLEN(sv) ((XPVLV*) SvANY(sv))->xlv_targlen #define LvFLAGS(sv) ((XPVLV*) SvANY(sv))->xlv_flags diff --git a/t/op/array.t b/t/op/array.t index e30dcebb73ee..1064ed7da380 100644 --- a/t/op/array.t +++ b/t/op/array.t @@ -6,7 +6,7 @@ BEGIN { require 'test.pl'; } -plan (129); +plan (135); # # @foo, @bar, and @ary are also used from tie-stdarray after tie-ing them @@ -473,5 +473,25 @@ sub { is \$_[0], \undef, 'undef preserves identity in array [perl #109726]'; }->(undef); +# [perl #118691] +@plink=@plunk=(); +$plink[3] = 1; +sub { + $_[0] = 2; + is $plink[0], 2, '@_ alias to nonexistent elem within array'; + $_[1] = 3; + is $plink[1], 3, '@_ alias to nonexistent neg index within array'; + is $_[2], undef, 'reading alias to negative index past beginning'; + eval { $_[2] = 42 }; + like $@, qr/Modification of non-creatable array value attempted, (?x: + )subscript -5/, + 'error when setting alias to negative index past beginning'; + is $_[3], undef, 'reading alias to -1 elem of empty array'; + eval { $_[3] = 42 }; + like $@, qr/Modification of non-creatable array value attempted, (?x: + )subscript -1/, + 'error when setting alias to -1 elem of empty array'; +}->($plink[0], $plink[-2], $plink[-5], $plunk[-1]); + "We're included by lib/Tie/Array/std.t so we need to return something true";