In perl.git, the branch smoke-me/jkeenan/130635-storable has been updated <http://perl5.git.perl.org/perl.git/commitdiff/ad11fd246390e8ba29f86a7da624dacefcfb1555?hp=d6115793d6cc41755a3ed4baaa38d30653656f41>
discards d6115793d6cc41755a3ed4baaa38d30653656f41 (commit) - Log ----------------------------------------------------------------- commit ad11fd246390e8ba29f86a7da624dacefcfb1555 Author: John Lightsey <[email protected]> Date: Tue Jan 24 10:30:18 2017 -0600 Fix stack buffer overflow in deserialization of hooks. The use of signed lengths resulted in a stack overflow in retrieve_hook() when a negative length was provided in the storable data. The retrieve_blessed() codepath had a similar problem with the placement of the trailing null byte when negative lengths were provided. ----------------------------------------------------------------------- Summary of changes: dump.c | 36 +++++++++++++++++++++--------------- embed.fnc | 4 ++-- embed.h | 2 +- gv.c | 2 +- op.c | 6 ++++++ pod/perlfunc.pod | 35 +++++++++++++++++++++++++---------- pp.c | 2 +- proto.h | 8 ++++---- regcomp.c | 44 ++++++++++++++++++++++++++++---------------- sv.c | 2 ++ t/comp/fold.t | 5 ++++- t/lib/warnings/toke | 12 ++++++++++++ t/op/aassign.t | 2 +- t/op/ord.t | 8 +++++++- t/op/signatures.t | 6 ++++++ t/op/write.t | 22 +++++++++++++++++++++- t/re/pat_rt_report.t | 12 +++++++++++- t/run/switchDx.t | 2 +- toke.c | 21 +++++++++------------ 19 files changed, 163 insertions(+), 68 deletions(-) mode change 100755 => 100644 pod/perlfunc.pod diff --git a/dump.c b/dump.c index 9edc8bf7db..9eb26bcc94 100644 --- a/dump.c +++ b/dump.c @@ -684,27 +684,33 @@ Perl_dump_sub(pTHX_ const GV *gv) void Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl) { - STRLEN len; - SV * const sv = newSVpvs_flags("", SVs_TEMP); - SV *tmpsv; - const char * name; + CV *cv; PERL_ARGS_ASSERT_DUMP_SUB_PERL; - if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv)))) + cv = isGV_with_GP(gv) ? GvCV(gv) : + (assert(SvROK((SV*)gv)), (CV*)SvRV((SV*)gv)); + if (justperl && (CvISXSUB(cv) || !CvROOT(cv))) return; - tmpsv = newSVpvs_flags("", SVs_TEMP); - gv_fullname3(sv, gv, NULL); - name = SvPV_const(sv, len); - Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", - generic_pv_escape(tmpsv, name, len, SvUTF8(sv))); - if (CvISXSUB(GvCV(gv))) + if (isGV_with_GP(gv)) { + SV * const namesv = newSVpvs_flags("", SVs_TEMP); + SV *escsv = newSVpvs_flags("", SVs_TEMP); + const char *namepv; + STRLEN namelen; + gv_fullname3(namesv, gv, NULL); + namepv = SvPV_const(namesv, namelen); + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ", + generic_pv_escape(escsv, namepv, namelen, SvUTF8(namesv))); + } else { + Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB = "); + } + if (CvISXSUB(cv)) Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n", - PTR2UV(CvXSUB(GvCV(gv))), - (int)CvXSUBANY(GvCV(gv)).any_i32); - else if (CvROOT(GvCV(gv))) - op_dump(CvROOT(GvCV(gv))); + PTR2UV(CvXSUB(cv)), + (int)CvXSUBANY(cv).any_i32); + else if (CvROOT(cv)) + op_dump(CvROOT(cv)); else Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n"); } diff --git a/embed.fnc b/embed.fnc index 1b05dd072f..d84f31353b 100644 --- a/embed.fnc +++ b/embed.fnc @@ -2340,7 +2340,7 @@ Es |bool |grok_bslash_N |NN RExC_state_t *pRExC_state \ |const bool strict \ |const U32 depth Es |void |reginsert |NN RExC_state_t *pRExC_state \ - |U8 op|NN regnode *opnd|U32 depth + |U8 op|NN regnode *operand|U32 depth Es |void |regtail |NN RExC_state_t * pRExC_state \ |NN const regnode * const p \ |NN const regnode * const val \ @@ -2645,7 +2645,7 @@ sR |SV* |get_and_check_backslash_N_name|NN const char* s \ |NN const char* const e sR |char* |scan_formline |NN char *s sR |char* |scan_heredoc |NN char *s -s |char* |scan_ident |NN char *s|NN char *dest \ +s |char* |scan_ident |NN char *s|NN const char *send|NN char *dest \ |STRLEN destlen|I32 ck_uni sR |char* |scan_inputsymbol|NN char *start sR |char* |scan_pat |NN char *start|I32 type diff --git a/embed.h b/embed.h index 2233a35e80..72950ae44b 100644 --- a/embed.h +++ b/embed.h @@ -1815,7 +1815,7 @@ #define scan_const(a) S_scan_const(aTHX_ a) #define scan_formline(a) S_scan_formline(aTHX_ a) #define scan_heredoc(a) S_scan_heredoc(aTHX_ a) -#define scan_ident(a,b,c,d) S_scan_ident(aTHX_ a,b,c,d) +#define scan_ident(a,b,c,d,e) S_scan_ident(aTHX_ a,b,c,d,e) #define scan_inputsymbol(a) S_scan_inputsymbol(aTHX_ a) #define scan_pat(a,b) S_scan_pat(aTHX_ a,b) #define scan_str(a,b,c,d,e) S_scan_str(aTHX_ a,b,c,d,e) diff --git a/gv.c b/gv.c index ae800c923b..8c85614386 100644 --- a/gv.c +++ b/gv.c @@ -736,7 +736,7 @@ S_gv_fetchmeth_internal(pTHX_ HV* stash, SV* meth, const char* name, STRLEN len, /* check locally for a real method or a cache entry */ he = (HE*)hv_common( - cachestash, meth, name, len, (flags & SVf_UTF8) ? HVhek_UTF8 : 0, create, NULL, 0 + cachestash, meth, name, len, is_utf8 ? HVhek_UTF8 : 0, create, NULL, 0 ); if (he) gvp = (GV**)&HeVAL(he); else gvp = NULL; diff --git a/op.c b/op.c index c4c9fc0171..c9e2078589 100644 --- a/op.c +++ b/op.c @@ -4632,6 +4632,7 @@ S_gen_constant_list(pTHX_ OP *o) COP not_compiling; int ret = 0; dJMPENV; + bool op_was_null; list(o); if (PL_parser && PL_parser->error_count) @@ -4640,7 +4641,12 @@ S_gen_constant_list(pTHX_ OP *o) curop = LINKLIST(o); old_next = o->op_next; o->op_next = 0; + op_was_null = o->op_type == OP_NULL; + if (op_was_null) + o->op_type = OP_CUSTOM; CALL_PEEP(curop); + if (op_was_null) + o->op_type = OP_NULL; S_prune_chain_head(&curop); PL_op = curop; diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod old mode 100755 new mode 100644 index 6294b5d65f..2b962aa9a3 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -7322,22 +7322,37 @@ name of the variables in the sort block : package main; my $a = "C"; # DANGER, Will Robinson, DANGER !!! - print sort { $a cmp $b } qw(A C E G B D F H); # WRONG + print sort { $a cmp $b } qw(A C E G B D F H); + # WRONG sub badlexi { $a cmp $b } - print sort badlexi qw(A C E G B D F H); # WRONG - # the above print BACFEDGH or some other incorrect ordering - - print sort { $::a cmp $::b } qw(A C E G B D F H); # OK - print sort { our $a cmp our $b } qw(A C E G B D F H); # also OK - print sort { our ($a, $b); $a cmp $b } qw(A C E G B D F H); # also OK + print sort badlexi qw(A C E G B D F H); + # WRONG + # the above prints BACFEDGH or some other incorrect ordering + + print sort { $::a cmp $::b } qw(A C E G B D F H); + # OK + print sort { our $a cmp our $b } qw(A C E G B D F H); + # also OK + print sort { our ($a, $b); $a cmp $b } qw(A C E G B D F H); + # also OK sub lexi { our $a cmp our $b } - print sort lexi qw(A C E G B D F H); # also OK + print sort lexi qw(A C E G B D F H); + # also OK # the above print ABCDEFGH With proper care you may mix package and my (or state) C<$a> and/or C<$b>: - my $a = { tiny => -2, small => -1, normal => 0, big => 1, huge => 2 }; - say sort { $a->{our $a} <=> $a->{our $b} } qw{ huge normal tiny small big}; + my $a = { + tiny => -2, + small => -1, + normal => 0, + big => 1, + huge => 2 + }; + + say sort { $a->{our $a} <=> $a->{our $b} } + qw{ huge normal tiny small big}; + # prints tinysmallnormalbighuge C<$a> and C<$b> are implicitely local to the sort() execution and regain their diff --git a/pp.c b/pp.c index 657abf7450..3e6b891f25 100644 --- a/pp.c +++ b/pp.c @@ -3626,7 +3626,7 @@ PP(pp_ord) const U8 *s = (U8*)SvPV_const(argsv, len); SETu(DO_UTF8(argsv) - ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) + ? (len ? utf8n_to_uvchr(s, len, 0, UTF8_ALLOW_ANYUV) : 0) : (UV)(*s)); return NORMAL; diff --git a/proto.h b/proto.h index 007bff78ec..46556eec17 100644 --- a/proto.h +++ b/proto.h @@ -5042,9 +5042,9 @@ STATIC regnode* S_regclass(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 dept STATIC unsigned int S_regex_set_precedence(const U8 my_operator) __attribute__warn_unused_result__; -STATIC void S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth); +STATIC void S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *operand, U32 depth); #define PERL_ARGS_ASSERT_REGINSERT \ - assert(pRExC_state); assert(opnd) + assert(pRExC_state); assert(operand) STATIC regnode* S_regnode_guts(pTHX_ RExC_state_t *pRExC_state, const U8 op, const STRLEN extra_len, const char* const name); #define PERL_ARGS_ASSERT_REGNODE_GUTS \ assert(pRExC_state); assert(name) @@ -5552,9 +5552,9 @@ STATIC char* S_scan_heredoc(pTHX_ char *s) #define PERL_ARGS_ASSERT_SCAN_HEREDOC \ assert(s) -STATIC char* S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni); +STATIC char* S_scan_ident(pTHX_ char *s, const char *send, char *dest, STRLEN destlen, I32 ck_uni); #define PERL_ARGS_ASSERT_SCAN_IDENT \ - assert(s); assert(dest) + assert(s); assert(send); assert(dest) STATIC char* S_scan_inputsymbol(pTHX_ char *start) __attribute__warn_unused_result__; #define PERL_ARGS_ASSERT_SCAN_INPUTSYMBOL \ diff --git a/regcomp.c b/regcomp.c index 4f54b0185e..0a315cbdbc 100644 --- a/regcomp.c +++ b/regcomp.c @@ -7789,6 +7789,18 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, while ( RExC_recurse_count > 0 ) { const regnode *scan = RExC_recurse[ --RExC_recurse_count ]; + /* + * This data structure is set up in study_chunk() and is used + * to calculate the distance between a GOSUB regopcode and + * the OPEN/CURLYM (CURLYM's are special and can act like OPEN's) + * it refers to. + * + * If for some reason someone writes code that optimises + * away a GOSUB opcode then the assert should be changed to + * an if(scan) to guard the ARG2L_SET() - Yves + * + */ + assert(scan && OP(scan) == GOSUB); ARG2L_SET( scan, RExC_open_parens[ARG(scan)] - scan ); } @@ -11709,19 +11721,11 @@ S_regpiece(pTHX_ RExC_state_t *pRExC_state, I32 *flagp, U32 depth) nextchar(pRExC_state); if (max < min) { /* If can't match, warn and optimize to fail unconditionally */ - if (SIZE_ONLY) { - - /* We can't back off the size because we have to reserve - * enough space for all the things we are about to throw - * away, but we can shrink it by the amount we are about - * to re-use here */ - RExC_size += PREVOPER(RExC_size) - regarglen[(U8)OPFAIL]; - } - else { + reginsert(pRExC_state, OPFAIL, orig_emit, depth+1); + if (PASS2) { ckWARNreg(RExC_parse, "Quantifier {n,m} with n > m can't match"); - RExC_emit = orig_emit; + NEXT_OFF(orig_emit)= regarglen[OPFAIL] + NODE_STEP_REGNODE; } - ret = reganode(pRExC_state, OPFAIL, 0); return ret; } else if (min == max && *RExC_parse == '?') @@ -18499,9 +18503,17 @@ S_reg2Lanode(pTHX_ RExC_state_t *pRExC_state, const U8 op, const U32 arg1, const - reginsert - insert an operator in front of already-emitted operand * * Means relocating the operand. +* +* IMPORTANT NOTE - it is the *callers* responsibility to correctly +* set up NEXT_OFF() of the inserted node if needed. Something like this: +* +* reginsert(pRExC, OPFAIL, orig_emit, depth+1); +* if (PASS2) +* NEXT_OFF(orig_emit) = regarglen[OPFAIL] + NODE_STEP_REGNODE; +* */ STATIC void -S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth) +S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *operand, U32 depth) { regnode *src; regnode *dst; @@ -18535,13 +18547,13 @@ S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth) /* note, RExC_open_parens[0] is the start of the * regex, it can't move. RExC_close_parens[0] is the end * of the regex, it *can* move. */ - if ( paren && RExC_open_parens[paren] >= opnd ) { + if ( paren && RExC_open_parens[paren] >= operand ) { /*DEBUG_PARSE_FMT("open"," - %d",size);*/ RExC_open_parens[paren] += size; } else { /*DEBUG_PARSE_FMT("open"," - %s","ok");*/ } - if ( RExC_close_parens[paren] >= opnd ) { + if ( RExC_close_parens[paren] >= operand ) { /*DEBUG_PARSE_FMT("close"," - %d",size);*/ RExC_close_parens[paren] += size; } else { @@ -18552,7 +18564,7 @@ S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth) if (RExC_end_op) RExC_end_op += size; - while (src > opnd) { + while (src > operand) { StructCopy(--src, --dst, regnode); #ifdef RE_TRACK_PATTERN_OFFSETS if (RExC_offsets) { /* MJD 20010112 */ @@ -18573,7 +18585,7 @@ S_reginsert(pTHX_ RExC_state_t *pRExC_state, U8 op, regnode *opnd, U32 depth) } - place = opnd; /* Op node, where operand used to be. */ + place = operand; /* Op node, where operand used to be. */ #ifdef RE_TRACK_PATTERN_OFFSETS if (RExC_offsets) { /* MJD */ MJD_OFFSET_DEBUG( diff --git a/sv.c b/sv.c index bbdca0bf08..339fa1b7d3 100644 --- a/sv.c +++ b/sv.c @@ -4985,6 +4985,8 @@ Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len) PERL_ARGS_ASSERT_SV_SETPVN; SV_CHECK_THINKFIRST_COW_DROP(sv); + if (isGV_with_GP(sv)) + Perl_croak_no_modify(); if (!ptr) { (void)SvOK_off(sv); return; diff --git a/t/comp/fold.t b/t/comp/fold.t index a875b5bdef..a72394e8cf 100644 --- a/t/comp/fold.t +++ b/t/comp/fold.t @@ -4,7 +4,7 @@ # we've not yet verified that use works. # use strict; -print "1..34\n"; +print "1..35\n"; my $test = 0; # Historically constant folding was performed by evaluating the ops, and if @@ -189,3 +189,6 @@ $b = 0; $a = eval 'my @z; @z = 0..~0 if $b; 3'; is ($a, 3, "list constant folding doesn't signal compile-time error"); is ($@, '', 'no error'); + +$a = eval 'local $SIG{__WARN__} = sub {}; join("", ":".."~", "z")'; +is ($a, ":z", "aborted list constant folding still executable"); diff --git a/t/lib/warnings/toke b/t/lib/warnings/toke index 1f971e88d2..2774f08dd1 100644 --- a/t/lib/warnings/toke +++ b/t/lib/warnings/toke @@ -1637,3 +1637,15 @@ EXPECT OPTION fatal Malformed UTF-8 character: \xc3\x20 (unexpected non-continuation byte 0x20, immediately after start byte 0xc3; need 2 bytes, got 1) in eval "string" at - line 11. Malformed UTF-8 character (fatal) at - line 11. +######## +# NAME [perl $130666] Assertion failure +no warnings "uninitialized"; +BEGIN{$^H=-1};my $l; s$0[$l] +EXPECT +######## +# NAME [perl $129036] Assertion failure +BEGIN{$0="";$^H=hex join""=>A00000}p? +EXPECT +OPTION fatal +syntax error at - line 1, at EOF +Execution of - aborted due to compilation errors. diff --git a/t/op/aassign.t b/t/op/aassign.t index b8025cfcff..4e7aee7017 100644 --- a/t/op/aassign.t +++ b/t/op/aassign.t @@ -272,7 +272,7 @@ sub sh { SKIP: { use Config; # debugging builds will detect this failure and panic - skip "DEBUGGING build" if $::Config{ccflags} =~ /DEBUGGING/ + skip "DEBUGGING build" if $::Config{ccflags} =~ /(?<!\S)-DDEBUGGING(?!\S)/ or $^O eq 'VMS' && $::Config{usedebugging_perl} eq 'Y'; local $::TODO = 'cheat and optimise my (....) = @_'; local @_ = 1..3; diff --git a/t/op/ord.t b/t/op/ord.t index deb08802f5..5776755983 100644 --- a/t/op/ord.t +++ b/t/op/ord.t @@ -6,7 +6,7 @@ BEGIN { set_up_inc(qw(. ../lib)); # ../lib needed for test.deparse } -plan tests => 35; +plan tests => 38; # compile time evaluation @@ -66,3 +66,9 @@ is(ord($x), 0x1234, 'runtime ord \x{....}'); is(ord(chr(0x1FFFFF)), 0x1FFFFF, 'last four-byte char in UTF-8'); is(ord(chr(0x200000)), 0x200000, 'first five-byte char in UTF-8'); } + +is(ord(""), 0, "ord of literal empty string"); +is(ord(do { my $x = ""; utf8::downgrade($x); $x }), 0, + "ord of downgraded empty string"); +is(ord(do { my $x = ""; utf8::upgrade($x); $x }), 0, + "ord of upgraded empty string"); diff --git a/t/op/signatures.t b/t/op/signatures.t index 0e53bf05d2..aa785bf65c 100644 --- a/t/op/signatures.t +++ b/t/op/signatures.t @@ -1463,6 +1463,12 @@ is scalar(t145()), undef; "masking warning"; } +# RT #130661 a char >= 0x80 in a signature when a sigil was expected +# was triggering an assertion + +eval "sub (\x80"; +like $@, qr/A signature parameter must start with/, "RT #130661"; + use File::Spec::Functions; diff --git a/t/op/write.t b/t/op/write.t index 31726812ba..d41e854c8a 100644 --- a/t/op/write.t +++ b/t/op/write.t @@ -98,7 +98,7 @@ for my $tref ( @NumTests ){ my $bas_tests = 21; # number of tests in section 3 -my $bug_tests = 66 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 6 + 2 + 3 + 96 + 11 + 4; +my $bug_tests = 66 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 6 + 2 + 3 + 96 + 11 + 12; # number of tests in section 4 my $hmb_tests = 37; @@ -2001,6 +2001,26 @@ EOP { stderr => 1 }, '#128255 Assert fail in S_sublex_done'); +{ + $^A = ""; + my $a = *globcopy; + my $r = eval { formline "^<<", $a }; + is $@, ""; + ok $r, "^ format with glob copy"; + is $^A, "*ma", "^ format with glob copy"; + is $a, "in::globcopy", "^ format with glob copy"; +} + +{ + $^A = ""; + my $r = eval { formline "^<<", *realglob }; + like $@, qr/\AModification of a read-only value attempted /; + is $r, undef, "^ format with real glob"; + is $^A, "*ma", "^ format with real glob"; + is ref(\*realglob), "GLOB"; +} + +$^A = ""; ############################# ## Section 4 diff --git a/t/re/pat_rt_report.t b/t/re/pat_rt_report.t index 2b6063c328..dd740e713b 100644 --- a/t/re/pat_rt_report.t +++ b/t/re/pat_rt_report.t @@ -20,7 +20,7 @@ use warnings; use 5.010; use Config; -plan tests => 2502; # Update this when adding/deleting tests. +plan tests => 2504; # Update this when adding/deleting tests. run_tests() unless caller; @@ -1131,6 +1131,16 @@ EOP my $s = "\x{f2}\x{140}\x{fe}\x{ff}\x{ff}\x{ff}"; ok($s !~ /^0000.\34500\376\377\377\377/, "RT #129085"); } + { + # rt + fresh_perl_is( + 'no warnings "regexp"; "foo"=~/((?1)){8,0}/; print "ok"', + "ok", {}, 'RT #130561 - allowing impossible quantifier should not cause SEGVs'); + my $s= "foo"; + no warnings 'regexp'; + ok($s=~/(foo){1,0}|(?1)/, + "RT #130561 - allowing impossible quantifier should not break recursion"); + } } # End of sub run_tests diff --git a/t/run/switchDx.t b/t/run/switchDx.t index 43f31bf9b9..9ea0a32542 100644 --- a/t/run/switchDx.t +++ b/t/run/switchDx.t @@ -11,7 +11,7 @@ use Config; my $perlio_log = "perlio$$.txt"; skip_all "DEBUGGING build required" - unless $::Config{ccflags} =~ /DEBUGGING/ + unless $::Config{ccflags} =~ /(?<!\S)-DDEBUGGING(?!\S)/ or $^O eq 'VMS' && $::Config{usedebugging_perl} eq 'Y'; plan tests => 8; diff --git a/toke.c b/toke.c index 864c5269c3..7dcdd5afa1 100644 --- a/toke.c +++ b/toke.c @@ -4166,10 +4166,7 @@ S_intuit_more(pTHX_ char *s) weight -= seen[un_char] * 10; if (isWORDCHAR_lazy_if_safe(s+1, PL_bufend, UTF)) { int len; - char *tmp = PL_bufend; - PL_bufend = (char*)send; - scan_ident(s, tmpbuf, sizeof tmpbuf, FALSE); - PL_bufend = tmp; + scan_ident(s, send, tmpbuf, sizeof tmpbuf, FALSE); len = (int)strlen(tmpbuf); if (len > 1 && gv_fetchpvn_flags(tmpbuf, len, UTF ? SVf_UTF8 : 0, SVt_PV)) @@ -5040,7 +5037,7 @@ Perl_yylex(pTHX) * as a var; e.g. ($, ...) would be seen as the var '$,' */ - char sigil; + U8 sigil; s = skipspace(s); sigil = *s++; @@ -5693,7 +5690,7 @@ Perl_yylex(pTHX) case '*': if (PL_expect == XPOSTDEREF) POSTDEREF('*'); if (PL_expect != XOPERATOR) { - s = scan_ident(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE); + s = scan_ident(s, PL_bufend, PL_tokenbuf, sizeof PL_tokenbuf, TRUE); PL_expect = XOPERATOR; force_ident(PL_tokenbuf, '*'); if (!*PL_tokenbuf) @@ -5736,7 +5733,7 @@ Perl_yylex(pTHX) } else if (PL_expect == XPOSTDEREF) POSTDEREF('%'); PL_tokenbuf[0] = '%'; - s = scan_ident(s, PL_tokenbuf + 1, + s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE); pl_yylval.ival = 0; if (!PL_tokenbuf[1]) { @@ -6283,7 +6280,7 @@ Perl_yylex(pTHX) } PL_tokenbuf[0] = '&'; - s = scan_ident(s - 1, PL_tokenbuf + 1, + s = scan_ident(s - 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE); pl_yylval.ival = (OPpENTERSUB_AMPER<<8); if (PL_tokenbuf[1]) { @@ -6546,7 +6543,7 @@ Perl_yylex(pTHX) || strchr("{$:+-@", s[2]))) { PL_tokenbuf[0] = '@'; - s = scan_ident(s + 1, PL_tokenbuf + 1, + s = scan_ident(s + 1, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE); if (PL_expect == XOPERATOR) { d = s; @@ -6564,7 +6561,7 @@ Perl_yylex(pTHX) } PL_tokenbuf[0] = '$'; - s = scan_ident(s, PL_tokenbuf + 1, + s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE); if (PL_expect == XOPERATOR) { d = s; @@ -6700,7 +6697,7 @@ Perl_yylex(pTHX) if (PL_expect == XPOSTDEREF) POSTDEREF('@'); PL_tokenbuf[0] = '@'; - s = scan_ident(s, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE); + s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE); if (PL_expect == XOPERATOR) { d = s; if (PL_bufptr > s) { @@ -9260,7 +9257,7 @@ S_scan_word(pTHX_ char *s, char *dest, STRLEN destlen, int allow_package, STRLEN && LIKELY((U8) *(s) != LATIN1_TO_NATIVE(0xAD))))) STATIC char * -S_scan_ident(pTHX_ char *s, char *dest, STRLEN destlen, I32 ck_uni) +S_scan_ident(pTHX_ char *s, const char *send, char *dest, STRLEN destlen, I32 ck_uni) { I32 herelines = PL_parser->herelines; SSize_t bracket = -1; -- Perl5 Master Repository
