In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/7b6e8075e45ebc684565efbe3ce7b70435f20c79?hp=425b8234618a94b12ca70c9914e5818c3952c7ed>
- Log ----------------------------------------------------------------- commit 7b6e8075e45ebc684565efbe3ce7b70435f20c79 Author: Father Chrysostomos <[email protected]> Date: Fri Sep 6 23:21:56 2013 -0700 Let av_push accept NULL values Now that NULL is used for a nonexistent element, it is easy for XS code to pass it to av_push(). av_store already accepts NULL, and av_push already works with it on non-debugging builds, so there is really no need for this restriction. M MANIFEST M embed.fnc M ext/XS-APItest/APItest.xs A ext/XS-APItest/t/av.t M proto.h commit 313efa9019b629125306f4c66c583d70960482b8 Author: Father Chrysostomos <[email protected]> Date: Fri Sep 6 18:07:50 2013 -0700 Stop Devel'Peek'Dump with no args from crashing I accidentally broke this in commit xxxxxxxx (5.19.3). The crash hap- pened at compile time. M ext/Devel-Peek/Peek.xs M ext/Devel-Peek/t/Peek.t commit 958c98f0f80fcd212653c42fe408bb6d9eb1f6d0 Author: Father Chrysostomos <[email protected]> Date: Fri Sep 6 16:06:07 2013 -0700 regcomp.c:S_concat_pat: Allow 64-bit array offsets M regcomp.c commit 0cb43d32ad1fb3ae746cfccf03ac6197a775a4ec Author: Father Chrysostomos <[email protected]> Date: Fri Sep 6 16:04:40 2013 -0700 Make /@array/ handle nonexistent array elements Commit ce0d59f changed AVs to use NULLs for nonexistent elements. S_concat_pat in regcomp.c needs to account for that, to avoid crashing. M regcomp.c M t/re/pat.t commit de935cc90faecfae2bc1afad24f1b5315a7787a0 Author: Father Chrysostomos <[email protected]> Date: Fri Sep 6 12:35:56 2013 -0700 Allow 64-bit array and stack offsets in entersub & goto I donât have enough memory to test this, but it needs to be done even- tually anyway. M pp_ctl.c M pp_hot.c commit 8c9d3376fbfa04ec0e0e2164dcf7d9e824cf0e94 Author: Father Chrysostomos <[email protected]> Date: Fri Sep 6 08:30:41 2013 -0700 Stop &xsub and goto &xsub from crashing on undef *_ $ perl -e 'undef *_; &Internals::V' Segmentation fault: 11 $ perl -e 'sub { undef *_; goto &Internals::V }->()' $ perl5.18.1 -e 'sub { undef *_; goto &Internals::V }->()' Segmentation fault: 11 The goto case is actually a regression from 5.16 (049bd5ffd62), as goto used to ignore changes to *_. (Fixing one bug uncovers another.) We shouldnât assume that GvAV(PL_defgv) (*_{ARRAY}) gives us anything. While weâre at it, since we have to add extra checks anyway, use them to speed up empty @_ in goto (by checking items, rather than arg). M pp_ctl.c M pp_hot.c M t/op/goto.t M t/op/sub.t ----------------------------------------------------------------------- Summary of changes: MANIFEST | 1 + embed.fnc | 2 +- ext/Devel-Peek/Peek.xs | 7 +++++++ ext/Devel-Peek/t/Peek.t | 6 ++++++ ext/XS-APItest/APItest.xs | 5 +++++ ext/XS-APItest/t/av.t | 14 ++++++++++++++ pp_ctl.c | 12 +++++++----- pp_hot.c | 10 +++++----- proto.h | 5 ++--- regcomp.c | 7 ++++--- t/op/goto.t | 9 ++++++++- t/op/sub.t | 9 ++++++++- t/re/pat.t | 10 +++++++++- 13 files changed, 77 insertions(+), 20 deletions(-) create mode 100644 ext/XS-APItest/t/av.t diff --git a/MANIFEST b/MANIFEST index 4679c95..d1cc4f1 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3941,6 +3941,7 @@ ext/XS-APItest/README XS::APItest extension ext/XS-APItest/t/addissub.t test op check wrapping ext/XS-APItest/t/arrayexpr.t test recursive descent expression parsing ext/XS-APItest/t/autoload.t Test XS AUTOLOAD routines +ext/XS-APItest/t/av.t Test AV functions ext/XS-APItest/t/BHK.pm Helper for ./blockhooks.t ext/XS-APItest/t/blockasexpr.t test recursive descent block parsing ext/XS-APItest/t/blockhooks-csc.t XS::APItest: more tests for PL_blockhooks diff --git a/embed.fnc b/embed.fnc index 11425ad..4940ae4 100644 --- a/embed.fnc +++ b/embed.fnc @@ -219,7 +219,7 @@ ApdR |SSize_t|av_len |NN AV *av ApdR |AV* |av_make |SSize_t size|NN SV **strp Apd |SV* |av_pop |NN AV *av ApdoxM |void |av_create_and_push|NN AV **const avp|NN SV *const val -Apd |void |av_push |NN AV *av|NN SV *val +Apd |void |av_push |NN AV *av|NULLOK SV *val : Used in scope.c, and by Data::Alias EXp |void |av_reify |NN AV *av ApdR |SV* |av_shift |NN AV *av diff --git a/ext/Devel-Peek/Peek.xs b/ext/Devel-Peek/Peek.xs index 73094b8..91b7555 100644 --- a/ext/Devel-Peek/Peek.xs +++ b/ext/Devel-Peek/Peek.xs @@ -389,6 +389,13 @@ S_ck_dump(pTHX_ OP *entersubop, GV *namegv, SV *cv) prev = aop; aop = aop->op_sibling; } + if (!aop) { + /* It doesnât really matter what we return here, as this only + occurs after yyerror. */ + op_free(first); + return entersubop; + } + /* aop now points to the second arg if there is one, the cvop otherwise */ if (aop->op_sibling) { diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index 929ce79..7025b45 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -1039,6 +1039,12 @@ SV = PV\($ADDR\) at $ADDR LEN = \d+ SUBSTR +# Dump with no arguments +eval 'Dump'; +like $@, qr/^Not enough arguments for Devel::Peek::Dump/, 'Dump;'; +eval 'Dump()'; +like $@, qr/^Not enough arguments for Devel::Peek::Dump/, 'Dump()'; + SKIP: { skip "Not built with usemymalloc", 2 unless $Config{usemymalloc} eq 'y'; diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs index 16d26de..85e2b01 100644 --- a/ext/XS-APItest/APItest.xs +++ b/ext/XS-APItest/APItest.xs @@ -3467,6 +3467,11 @@ alias_av(AV *av, IV ix, SV *sv) CODE: av_store(av, ix, SvREFCNT_inc(sv)); +void +av_pushnull(AV *av) + CODE: + av_push(av, NULL); + MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest int diff --git a/ext/XS-APItest/t/av.t b/ext/XS-APItest/t/av.t new file mode 100644 index 0000000..03e2aa6 --- /dev/null +++ b/ext/XS-APItest/t/av.t @@ -0,0 +1,14 @@ +#!perl + +use Test::More tests => 4; +use XS::APItest; + +av_pushnull \@_; +is $#_, 0, '$#_ after av_push(@_, NULL)'; +ok !exists $_[0], '!exists $_[0] after av_push(@_,NULL)'; + +use Tie::Array; +tie @tied, 'Tie::StdArray'; +av_pushnull \@tied; +is $#tied, 0, '$#tied after av_push(@tied, NULL)'; +is $tied[0], undef, '$tied[0] is undef after av_push(@tied,NULL)'; diff --git a/pp_ctl.c b/pp_ctl.c index 24a8cd6..7fd27f8 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2895,19 +2895,21 @@ PP(pp_goto) /* also pp_dump */ OP* const retop = cx->blk_sub.retop; SV **newsp; I32 gimme; - const SSize_t items = AvFILLp(arg) + 1; + const SSize_t items = arg ? AvFILLp(arg) + 1 : 0; SV** mark; PERL_UNUSED_VAR(newsp); PERL_UNUSED_VAR(gimme); /* put GvAV(defgv) back onto stack */ - EXTEND(SP, items+1); /* @_ could have been extended. */ - Copy(AvARRAY(arg), SP + 1, items, SV*); + if (items) { + EXTEND(SP, items+1); /* @_ could have been extended. */ + Copy(AvARRAY(arg), SP + 1, items, SV*); + } mark = SP; SP += items; - if (AvREAL(arg)) { - I32 index; + if (items && AvREAL(arg)) { + SSize_t index; for (index=0; index<items; index++) if (SP[-index]) SvREFCNT_inc_void_NN(sv_2mortal(SP[-index])); diff --git a/pp_hot.c b/pp_hot.c index 2598ef0..d3f8976 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -2640,7 +2640,7 @@ try_autoload: if (!(CvISXSUB(cv))) { /* This path taken at least 75% of the time */ dMARK; - I32 items = SP - MARK; + SSize_t items = SP - MARK; PADLIST * const padlist = CvPADLIST(cv); PUSHBLOCK(cx, CXt_SUB, MARK); PUSHSUB(cx); @@ -2703,7 +2703,7 @@ try_autoload: RETURNOP(CvSTART(cv)); } else { - I32 markix = TOPMARK; + SSize_t markix = TOPMARK; SAVETMPS; PUTBACK; @@ -2714,12 +2714,12 @@ try_autoload: !CvLVALUE(cv)) DIE(aTHX_ "Can't modify non-lvalue subroutine call"); - if (!hasargs) { + if (!hasargs && GvAV(PL_defgv)) { /* Need to copy @_ to stack. Alternative may be to * switch stack to @_, and copy return values * back. This would allow popping @_ in XSUB, e.g.. XXXX */ AV * const av = GvAV(PL_defgv); - const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */ + const SSize_t items = AvFILLp(av) + 1; /* @_ is not tieable */ if (items) { SSize_t i = 0; @@ -2736,7 +2736,7 @@ try_autoload: } else { SV **mark = PL_stack_base + markix; - I32 items = SP - mark; + SSize_t items = SP - mark; while (items--) { mark++; if (*mark && SvPADTMP(*mark) && !IS_PADGV(*mark)) diff --git a/proto.h b/proto.h index 7819f21..388fa64 100644 --- a/proto.h +++ b/proto.h @@ -221,10 +221,9 @@ PERL_CALLCONV SV* Perl_av_pop(pTHX_ AV *av) assert(av) PERL_CALLCONV void Perl_av_push(pTHX_ AV *av, SV *val) - __attribute__nonnull__(pTHX_1) - __attribute__nonnull__(pTHX_2); + __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_AV_PUSH \ - assert(av); assert(val) + assert(av) PERL_CALLCONV void Perl_av_reify(pTHX_ AV *av) __attribute__nonnull__(pTHX_1); diff --git a/regcomp.c b/regcomp.c index 450ac90..e0787e1 100644 --- a/regcomp.c +++ b/regcomp.c @@ -5030,6 +5030,7 @@ S_concat_pat(pTHX_ RExC_state_t * const pRExC_state, STRLEN orig_patlen = 0; bool code = 0; SV *msv = use_delim ? delim : *svp; + if (!msv) msv = &PL_sv_undef; /* if we've got a delimiter, we go round the loop twice for each * svp slot (except the last), using the delimiter the second @@ -5048,7 +5049,7 @@ S_concat_pat(pTHX_ RExC_state_t * const pRExC_state, * The code in this block is based on S_pushav() */ AV *const av = (AV*)msv; - const I32 maxarg = AvFILL(av) + 1; + const SSize_t maxarg = AvFILL(av) + 1; SV **array; if (oplist) { @@ -5058,11 +5059,11 @@ S_concat_pat(pTHX_ RExC_state_t * const pRExC_state, } if (SvRMAGICAL(av)) { - U32 i; + SSize_t i; Newx(array, maxarg, SV*); SAVEFREEPV(array); - for (i=0; i < (U32)maxarg; i++) { + for (i=0; i < maxarg; i++) { SV ** const svp = av_fetch(av, i, FALSE); array[i] = svp ? *svp : &PL_sv_undef; } diff --git a/t/op/goto.t b/t/op/goto.t index 1336685..5c96f8b 100644 --- a/t/op/goto.t +++ b/t/op/goto.t @@ -10,7 +10,7 @@ BEGIN { use warnings; use strict; -plan tests => 91; +plan tests => 92; our $TODO; my $deprecated = 0; @@ -491,6 +491,13 @@ is ${*__}[0], 'rough and tubbery', 'goto &foo leaves reified @_ alone'; is $_[0], "", 'content of nonexistent $_[0] is modified by goto &xsub'; } +# goto &xsub when @_ itself does not exist +undef *_; +eval { & { sub { goto &utf8::encode } } }; +# The main thing we are testing is that it did not crash. But make sure +# *_{ARRAY} was untouched, too. +is *_{ARRAY}, undef, 'goto &xsub when @_ does not exist'; + # [perl #36521] goto &foo in warn handler could defeat recursion avoider { diff --git a/t/op/sub.t b/t/op/sub.t index bbb9d76..2088662 100644 --- a/t/op/sub.t +++ b/t/op/sub.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan( tests => 29 ); +plan( tests => 30 ); sub empty_sub {} @@ -175,3 +175,10 @@ is eval { is @_, 1, 'num of elems in @_ after &xsub with nonexistent $_[0]'; is $_[0], "", 'content of nonexistent $_[0] is modified by &xsub'; } + +# &xsub when @_ itself does not exist +undef *_; +eval { &utf8::encode }; +# The main thing we are testing is that it did not crash. But make sure +# *_{ARRAY} was untouched, too. +is *_{ARRAY}, undef, 'goto &xsub when @_ does not exist'; diff --git a/t/re/pat.t b/t/re/pat.t index 5c44429..2586647 100644 --- a/t/re/pat.t +++ b/t/re/pat.t @@ -20,7 +20,7 @@ BEGIN { require './test.pl'; } -plan tests => 698; # Update this when adding/deleting tests. +plan tests => 699; # Update this when adding/deleting tests. run_tests() unless caller; @@ -1471,6 +1471,14 @@ EOP is ($s, 'XbXX$XX&', 'RT #45667 with /x'); } + { + no warnings "uninitialized"; + my @a; + $a[1]++; + /@a/; + pass('no crash with /@a/ when array has nonexistent elems'); + } + } # End of sub run_tests 1; -- Perl5 Master Repository
