In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/a271a376b9ff839eed6d1db3181e47e01d846591?hp=9bc7f50b6c983278ffa7b722240000d38037e149>
- Log ----------------------------------------------------------------- commit a271a376b9ff839eed6d1db3181e47e01d846591 Author: Smylers <[email protected]> Date: Fri Sep 6 06:02:41 2013 +0100 Update README copyright to 2013 For RT #119625. M README commit 199f858d54d30a550be7320e065420353bca5318 Author: Father Chrysostomos <[email protected]> Date: Fri Sep 6 00:51:16 2013 -0700 Put AV defelem creation code in one place M embed.fnc M embed.h M pp_ctl.c M pp_hot.c M proto.h M sv.c commit dd2a7f9048da2c440a4dfed5122c0bfd98f079d3 Author: Father Chrysostomos <[email protected]> Date: Fri Sep 6 00:17:05 2013 -0700 Use defelems for (goto) &xsub calls Before ce0d59f: $ perl -e '++$#_; &utf8::encode' Modification of a read-only value attempted at -e line 1. As of ce0d59f: $ ./perl -Ilib -e '++$#_; &utf8::encode' Assertion failed: (sv), function Perl_sv_utf8_encode, file sv.c, line 3581. Abort trap: 6 Calling sub { utf8::encode($_[0]) } should be more or less equivalent to calling utf8::encode, but it is not in this case: $ ./perl -Ilib -we '++$#_; &{sub { utf8::encode($_[0]) }}' Use of uninitialized value in subroutine entry at -e line 1. In the first two examples above, an implementation detail is leaking through. What you are seeing is not the array element, but a place- holder that indicates an element that has not been assigned to yet. We should use defelem magic so that what the XSUB assigns to will cre- ate an array element (as happens with utf8::encode($_[0])). All of the above applies to goto &xsub as well. M pp_ctl.c M pp_hot.c M t/op/goto.t M t/op/sub.t commit 956f23f034b0a3aa7c521134b47f388252b9f843 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 5 20:33:00 2013 -0700 pp_hot.c:pp_aelem: Use _NN in one spot This av can never be null here. av_len will already have failed an assertion if it is. M pp_hot.c commit 31c61addb4e0d00f3deb63c5f58bff0ecb6b6969 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 5 14:39:47 2013 -0700 Make pp_splice handle nonexistent array elements Commit ce0d59f changed AVs to use NULLs for nonexistent elements. pp_splice needs to take that into account and avoid pushing NULLs on to the stack. M pp.c M t/op/splice.t ----------------------------------------------------------------------- Summary of changes: README | 4 ++-- embed.fnc | 1 + embed.h | 1 + pp.c | 23 +++++++++++++++-------- pp_ctl.c | 7 ++++++- pp_hot.c | 28 ++++++++++------------------ proto.h | 7 +++++++ sv.c | 13 +++++++++++++ t/op/goto.t | 11 ++++++++++- t/op/splice.t | 10 ++++++++++ t/op/sub.t | 12 +++++++++++- 11 files changed, 86 insertions(+), 31 deletions(-) diff --git a/README b/README index 2967921..5cf3a9e 100644 --- a/README +++ b/README @@ -1,6 +1,6 @@ Perl is Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, -2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012 -by Larry Wall and others. All rights reserved. +2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, +2013 by Larry Wall and others. All rights reserved. diff --git a/embed.fnc b/embed.fnc index 088086e..11425ad 100644 --- a/embed.fnc +++ b/embed.fnc @@ -966,6 +966,7 @@ Apda |SV* |newRV_noinc |NN SV *const sv Apda |SV* |newSV |const STRLEN len Apa |OP* |newSVREF |NN OP* o Apda |OP* |newSVOP |I32 type|I32 flags|NN SV* sv +pa |SV* |newSVavdefelem |NN AV *av|SSize_t ix|bool extendible Apda |SV* |newSViv |const IV i Apda |SV* |newSVuv |const UV u Apda |SV* |newSVnv |const NV n diff --git a/embed.h b/embed.h index 7708a61..3662b97 100644 --- a/embed.h +++ b/embed.h @@ -1186,6 +1186,7 @@ #define my_unexec() Perl_my_unexec(aTHX) #define newATTRSUB_flags(a,b,c,d,e,f) Perl_newATTRSUB_flags(aTHX_ a,b,c,d,e,f) #define newSTUB(a,b) Perl_newSTUB(aTHX_ a,b) +#define newSVavdefelem(a,b,c) Perl_newSVavdefelem(aTHX_ a,b,c) #define newXS_len_flags(a,b,c,d,e,f,g) Perl_newXS_len_flags(aTHX_ a,b,c,d,e,f,g) #define nextargv(a) Perl_nextargv(aTHX_ a) #define oopsAV(a) Perl_oopsAV(aTHX_ a) diff --git a/pp.c b/pp.c index a913ec0..6fc6c9f 100644 --- a/pp.c +++ b/pp.c @@ -4975,14 +4975,18 @@ PP(pp_splice) MARK = ORIGMARK + 1; if (GIMME == G_ARRAY) { /* copy return vals to stack */ + const bool real = cBOOL(AvREAL(ary)); MEXTEND(MARK, length); - Copy(AvARRAY(ary)+offset, MARK, length, SV*); - if (AvREAL(ary)) { + if (real) EXTEND_MORTAL(length); - for (i = length, dst = MARK; i; i--) { + for (i = 0, dst = MARK; i < length; i++) { + if ((*dst = AvARRAY(ary)[i+offset])) { + if (real) sv_2mortal(*dst); /* free them eventually */ - dst++; } + else + *dst = &PL_sv_undef; + dst++; } MARK += length - 1; } @@ -5068,13 +5072,16 @@ PP(pp_splice) MARK = ORIGMARK + 1; if (GIMME == G_ARRAY) { /* copy return vals to stack */ if (length) { - Copy(tmparyval, MARK, length, SV*); - if (AvREAL(ary)) { + const bool real = cBOOL(AvREAL(ary)); + if (real) EXTEND_MORTAL(length); - for (i = length, dst = MARK; i; i--) { + for (i = 0, dst = MARK; i < length; i++) { + if ((*dst = tmparyval[i])) { + if (real) sv_2mortal(*dst); /* free them eventually */ - dst++; } + else *dst = &PL_sv_undef; + dst++; } } MARK += length - 1; diff --git a/pp_ctl.c b/pp_ctl.c index 4ce8ddb..d091e29 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2907,7 +2907,12 @@ PP(pp_goto) if (AvREAL(arg)) { I32 index; for (index=0; index<items; index++) - SvREFCNT_inc_void(sv_2mortal(SP[-index])); + if (SP[-index]) + SvREFCNT_inc_void_NN(sv_2mortal(SP[-index])); + else { + SP[-index] = sv_2mortal(newSVavdefelem(arg, + AvFILLp(arg) - index, 1)); + } } SvREFCNT_dec(arg); if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) { diff --git a/pp_hot.c b/pp_hot.c index 4faa738..2598ef0 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -1919,13 +1919,7 @@ PP(pp_iter) } } else if (!av_is_stack) { - SV *lv = newSV_type(SVt_PVLV); - LvTYPE(lv) = 'y'; - sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0); - LvTARG(lv) = SvREFCNT_inc_simple(av); - LvTARGOFF(lv) = ix; - LvTARGLEN(lv) = (STRLEN)UV_MAX; - sv = lv; + sv = newSVavdefelem(av, ix, 0); } else sv = &PL_sv_undef; @@ -2728,9 +2722,14 @@ try_autoload: const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */ if (items) { + SSize_t i = 0; /* Mark is at the end of the stack. */ EXTEND(SP, items); - Copy(AvARRAY(av), SP + 1, items, SV*); + for (; i < items; ++i) + if (AvARRAY(av)[i]) SP[i+1] = AvARRAY(av)[i]; + else { + SP[i+1] = newSVavdefelem(av, i, 1); + } SP += items; PUTBACK ; } @@ -2839,23 +2838,16 @@ 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); + mPUSHs(newSVavdefelem(av, /* 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); + elem < 0 && len + elem >= 0 ? len + elem : elem, + 1)); RETURN; } if (localizing) { diff --git a/proto.h b/proto.h index a3106cb..7819f21 100644 --- a/proto.h +++ b/proto.h @@ -2888,6 +2888,13 @@ PERL_CALLCONV SV* Perl_newSV_type(pTHX_ const svtype type) __attribute__malloc__ __attribute__warn_unused_result__; +PERL_CALLCONV SV* Perl_newSVavdefelem(pTHX_ AV *av, SSize_t ix, bool extendible) + __attribute__malloc__ + __attribute__warn_unused_result__ + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_NEWSVAVDEFELEM \ + assert(av) + PERL_CALLCONV SV* Perl_newSVhek(pTHX_ const HEK *const hek) __attribute__malloc__ __attribute__warn_unused_result__; diff --git a/sv.c b/sv.c index f53ffdd..d6f3338 100644 --- a/sv.c +++ b/sv.c @@ -9661,6 +9661,19 @@ Perl_newSVrv(pTHX_ SV *const rv, const char *const classname) return sv; } +SV * +Perl_newSVavdefelem(pTHX_ AV *av, SSize_t ix, bool extendible) +{ + SV * const lv = newSV_type(SVt_PVLV); + PERL_ARGS_ASSERT_NEWSVAVDEFELEM; + LvTYPE(lv) = 'y'; + sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0); + LvTARG(lv) = SvREFCNT_inc_simple_NN(av); + LvSTARGOFF(lv) = ix; + LvTARGLEN(lv) = extendible ? 1 : (STRLEN)UV_MAX; + return lv; +} + /* =for apidoc sv_setref_pv diff --git a/t/op/goto.t b/t/op/goto.t index 37b69e3..1336685 100644 --- a/t/op/goto.t +++ b/t/op/goto.t @@ -10,7 +10,7 @@ BEGIN { use warnings; use strict; -plan tests => 89; +plan tests => 91; our $TODO; my $deprecated = 0; @@ -481,6 +481,15 @@ is "@__", chr 256, 'goto &xsub with replaced *_{ARRAY}'; sub { *__ = \@_; goto &null } -> ("rough and tubbery"); is ${*__}[0], 'rough and tubbery', 'goto &foo leaves reified @_ alone'; +# goto &xsub when @_ has nonexistent elements +{ + no warnings "uninitialized"; + local @_ = (); + $#_++; + & {sub { goto &utf8::encode }}; + is @_, 1, 'num of elems in @_ after goto &xsub with nonexistent $_[0]'; + is $_[0], "", 'content of nonexistent $_[0] is modified by goto &xsub'; +} # [perl #36521] goto &foo in warn handler could defeat recursion avoider diff --git a/t/op/splice.t b/t/op/splice.t index d462f0c..510d4cb 100644 --- a/t/op/splice.t +++ b/t/op/splice.t @@ -92,4 +92,14 @@ ok( !oo->isa('Bar'), 'splice @ISA and make Foo a Bar'); eval { splice( $new_arrayref, 0, 0, 1, 2, 3 ) }; like($@, qr/Not an ARRAY/, 'undefined first argument to splice'); +# Test arrays with nonexistent elements (crashes when it fails) +@a = (); +$#a++; +is sprintf("%s", splice @a, 0, 1), "", + 'splice handles nonexistent elems when shrinking the array'; +@a = (); +$#a++; +is sprintf("%s", splice @a, 0, 1, undef), "", + 'splice handles nonexistent elems when array len stays the same'; + done_testing; diff --git a/t/op/sub.t b/t/op/sub.t index fc04ac8..bbb9d76 100644 --- a/t/op/sub.t +++ b/t/op/sub.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan( tests => 27 ); +plan( tests => 29 ); sub empty_sub {} @@ -165,3 +165,13 @@ is eval { is $w, undef, '*keyword = sub():method{$y} does not cause ambiguity warnings'; } + +# &xsub when @_ has nonexistent elements +{ + no warnings "uninitialized"; + local @_ = (); + $#_++; + &utf8::encode; + is @_, 1, 'num of elems in @_ after &xsub with nonexistent $_[0]'; + is $_[0], "", 'content of nonexistent $_[0] is modified by &xsub'; +} -- Perl5 Master Repository
