X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=f9f0627121a72ed607c2e178a339b7e1298a4d35;hb=780a5241a93925d81e932db73df46ee749b203b9;hp=f6e21a2614f8e96432fbb8842cffeb013f0267be;hpb=fc15ae8fb67c31ee845fb33ce00b1c24c4c1a908;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index f6e21a2..f9f0627 100644 --- a/toke.c +++ b/toke.c @@ -1,7 +1,7 @@ /* toke.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -23,8 +23,50 @@ #define PERL_IN_TOKE_C #include "perl.h" -#define yychar (*PL_yycharp) -#define yylval (*PL_yylvalp) +#define yylval (PL_parser->yylval) + +/* YYINITDEPTH -- initial size of the parser's stacks. */ +#define YYINITDEPTH 200 + +/* XXX temporary backwards compatibility */ +#define PL_lex_brackets (PL_parser->lex_brackets) +#define PL_lex_brackstack (PL_parser->lex_brackstack) +#define PL_lex_casemods (PL_parser->lex_casemods) +#define PL_lex_casestack (PL_parser->lex_casestack) +#define PL_lex_defer (PL_parser->lex_defer) +#define PL_lex_dojoin (PL_parser->lex_dojoin) +#define PL_lex_expect (PL_parser->lex_expect) +#define PL_lex_formbrack (PL_parser->lex_formbrack) +#define PL_lex_inpat (PL_parser->lex_inpat) +#define PL_lex_inwhat (PL_parser->lex_inwhat) +#define PL_lex_op (PL_parser->lex_op) +#define PL_lex_repl (PL_parser->lex_repl) +#define PL_lex_starts (PL_parser->lex_starts) +#define PL_lex_stuff (PL_parser->lex_stuff) +#define PL_multi_start (PL_parser->multi_start) +#define PL_multi_open (PL_parser->multi_open) +#define PL_multi_close (PL_parser->multi_close) +#define PL_pending_ident (PL_parser->pending_ident) +#define PL_preambled (PL_parser->preambled) +#define PL_sublex_info (PL_parser->sublex_info) + +#ifdef PERL_MAD +# define PL_endwhite (PL_parser->endwhite) +# define PL_faketokens (PL_parser->faketokens) +# define PL_lasttoke (PL_parser->lasttoke) +# define PL_nextwhite (PL_parser->nextwhite) +# define PL_realtokenstart (PL_parser->realtokenstart) +# define PL_skipwhite (PL_parser->skipwhite) +# define PL_thisclose (PL_parser->thisclose) +# define PL_thismad (PL_parser->thismad) +# define PL_thisopen (PL_parser->thisopen) +# define PL_thisstuff (PL_parser->thisstuff) +# define PL_thistoken (PL_parser->thistoken) +# define PL_thiswhite (PL_parser->thiswhite) +#endif + +static int +S_pending_ident(pTHX); static const char ident_too_long[] = "Identifier too long"; static const char commaless_variable_list[] = "comma-less variable list"; @@ -298,7 +340,7 @@ static struct debug_tokens { { WHEN, TOKENTYPE_IVAL, "WHEN" }, { WHILE, TOKENTYPE_IVAL, "WHILE" }, { WORD, TOKENTYPE_OPVAL, "WORD" }, - { 0, TOKENTYPE_NONE, 0 } + { 0, TOKENTYPE_NONE, NULL } }; /* dump the returned token in rv, plus any optional arg in yylval */ @@ -429,8 +471,8 @@ S_no_op(pTHX_ const char *what, char *s) "\t(Missing semicolon on previous line?)\n"); else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) { const char *t; - for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) - /**/; + for (t = PL_oldoldbufptr; (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) + NOOP; if (t < PL_bufptr && isSPACE(*t)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "\t(Do you need to predeclare %.*s?)\n", @@ -499,7 +541,7 @@ S_feature_is_enabled(pTHX_ const char *name, STRLEN namelen) dVAR; HV * const hinthv = GvHV(PL_hintgv); char he_name[32] = "feature_"; - (void) strncpy(&he_name[8], name, 24); + (void) my_strlcpy(&he_name[8], name, 24); return (hinthv && hv_exists(hinthv, he_name, 8 + namelen)); } @@ -569,6 +611,8 @@ S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) } #endif + + /* * Perl_lex_start * Initialize variables. Uses the Perl save_stack to save its state (for @@ -579,37 +623,36 @@ void Perl_lex_start(pTHX_ SV *line) { dVAR; - const char *s; + const char *s = NULL; STRLEN len; + yy_parser *parser; + + /* create and initialise a parser */ + + Newxz(parser, 1, yy_parser); + parser->old_parser = PL_parser; + PL_parser = parser; + + Newx(parser->stack, YYINITDEPTH, yy_stack_frame); + parser->ps = parser->stack; + parser->stack_size = YYINITDEPTH; + + parser->stack->state = 0; + parser->yyerrstatus = 0; + parser->yychar = YYEMPTY; /* Cause a token to be read. */ + + /* initialise lexer state */ - SAVEI32(PL_lex_dojoin); - SAVEI32(PL_lex_brackets); - SAVEI32(PL_lex_casemods); - SAVEI32(PL_lex_starts); SAVEI32(PL_lex_state); - SAVEVPTR(PL_lex_inpat); - SAVEI32(PL_lex_inwhat); #ifdef PERL_MAD if (PL_lex_state == LEX_KNOWNEXT) { - I32 toke = PL_lasttoke; + I32 toke = parser->old_parser->lasttoke; while (--toke >= 0) { SAVEI32(PL_nexttoke[toke].next_type); SAVEVPTR(PL_nexttoke[toke].next_val); if (PL_madskills) SAVEVPTR(PL_nexttoke[toke].next_mad); } - SAVEI32(PL_lasttoke); - } - if (PL_madskills) { - SAVESPTR(PL_thistoken); - SAVESPTR(PL_thiswhite); - SAVESPTR(PL_nextwhite); - SAVESPTR(PL_thisopen); - SAVESPTR(PL_thisclose); - SAVESPTR(PL_thisstuff); - SAVEVPTR(PL_thismad); - SAVEI32(PL_realtokenstart); - SAVEI32(PL_faketokens); } SAVEI32(PL_curforce); #else @@ -631,46 +674,37 @@ Perl_lex_start(pTHX_ SV *line) SAVEPPTR(PL_last_uni); SAVEPPTR(PL_linestart); SAVESPTR(PL_linestr); - SAVEGENERICPV(PL_lex_brackstack); - SAVEGENERICPV(PL_lex_casestack); SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp); - SAVESPTR(PL_lex_stuff); - SAVEI32(PL_lex_defer); - SAVEI32(PL_sublex_info.sub_inwhat); - SAVESPTR(PL_lex_repl); SAVEINT(PL_expect); - SAVEINT(PL_lex_expect); PL_lex_state = LEX_NORMAL; - PL_lex_defer = 0; PL_expect = XSTATE; - PL_lex_brackets = 0; - Newx(PL_lex_brackstack, 120, char); - Newx(PL_lex_casestack, 12, char); - PL_lex_casemods = 0; - *PL_lex_casestack = '\0'; - PL_lex_dojoin = 0; - PL_lex_starts = 0; - PL_lex_stuff = NULL; - PL_lex_repl = NULL; - PL_lex_inpat = 0; -#ifdef PERL_MAD - PL_lasttoke = 0; -#else + Newx(parser->lex_brackstack, 120, char); + Newx(parser->lex_casestack, 12, char); + *parser->lex_casestack = '\0'; +#ifndef PERL_MAD PL_nexttoke = 0; #endif - PL_lex_inwhat = 0; - PL_sublex_info.sub_inwhat = 0; - PL_linestr = line; - if (SvREADONLY(PL_linestr)) - PL_linestr = sv_2mortal(newSVsv(PL_linestr)); - s = SvPV_const(PL_linestr, len); - if (!len || s[len-1] != ';') { - if (!(SvFLAGS(PL_linestr) & SVs_TEMP)) - PL_linestr = sv_2mortal(newSVsv(PL_linestr)); - sv_catpvs(PL_linestr, "\n;"); - } - SvTEMP_off(PL_linestr); + + if (line) { + s = SvPV_const(line, len); + } else { + len = 0; + } + if (!len) { + PL_linestr = newSVpvs("\n;"); + } else if (SvREADONLY(line) || s[len-1] != ';') { + PL_linestr = newSVsv(line); + if (s[len-1] != ';') + sv_catpvs(PL_linestr, "\n;"); + } else { + SvTEMP_off(line); + SvREFCNT_inc_simple_void_NN(line); + PL_linestr = line; + } + /* PL_linestr needs to survive until end of scope, not just the next + FREETMPS. See changes 17505 and 17546 which fixed the symptoms only. */ + SAVEFREESV(PL_linestr); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr); PL_bufend = PL_bufptr + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = NULL; @@ -737,7 +771,9 @@ S_incline(pTHX_ char *s) e = t + 1; } else { - for (t = s; !isSPACE(*t); t++) ; + t = s; + while (!isSPACE(*t)) + t++; e = t; } while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f') @@ -774,12 +810,13 @@ S_incline(pTHX_ char *s) gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE); if (gvp) { gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE); - if (!isGV(gv2)) + if (!isGV(gv2)) { gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE); - /* adjust ${"::_ and it knows that the next char is a word char, then - * it calls S_force_word to stick the next word into the PL_next lookahead. + * it calls S_force_word to stick the next word into the PL_nexttoke/val + * lookahead. * * Arguments: * char *start : buffer position (must be within PL_linestr) - * int token : PL_next will be this type of bare word (e.g., METHOD,WORD) + * int token : PL_next* will be this type of bare word (e.g., METHOD,WORD) * int check_keyword : if true, Perl checks to make sure the word isn't * a keyword (do this if the word is a label, e.g. goto FOO) * int allow_pack : if true, : characters will also be allowed (require, @@ -1271,7 +1321,7 @@ S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow (allow_initial_tick && *s == '\'') ) { s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, allow_pack, &len); - if (check_keyword && keyword(PL_tokenbuf, len)) + if (check_keyword && keyword(PL_tokenbuf, len, 0)) return start; start_force(PL_curforce); if (PL_madskills) @@ -1306,7 +1356,7 @@ STATIC void S_force_ident(pTHX_ register const char *s, int kind) { dVAR; - if (s && *s) { + if (*s) { const STRLEN len = strlen(s); OP* const o = (OP*)newSVOP(OP_CONST, 0, newSVpvn(s, len)); start_force(PL_curforce); @@ -1537,6 +1587,14 @@ S_sublex_start(pTHX) PL_expect = XTERMORDORDOR; return THING; } + else if (op_type == OP_BACKTICK && PL_lex_op) { + /* readpipe() vas overriden */ + cSVOPx(cLISTOPx(cUNOPx(PL_lex_op)->op_first)->op_first->op_sibling)->op_sv = tokeq(PL_lex_stuff); + yylval.opval = PL_lex_op; + PL_lex_op = NULL; + PL_lex_stuff = NULL; + return THING; + } PL_sublex_info.super_state = PL_lex_state; PL_sublex_info.sub_inwhat = op_type; @@ -1670,7 +1728,7 @@ S_sublex_done(pTHX) if (PL_madskills) { if (PL_thiswhite) { if (!PL_endwhite) - PL_endwhite = newSVpvn("",0); + PL_endwhite = newSVpvs(""); sv_catsv(PL_endwhite, PL_thiswhite); PL_thiswhite = 0; } @@ -1695,12 +1753,12 @@ S_sublex_done(pTHX) Extracts a pattern, double-quoted string, or transliteration. This is terrifying code. - It looks at lex_inwhat and PL_lex_inpat to find out whether it's + It looks at PL_lex_inwhat and PL_lex_inpat to find out whether it's processing a pattern (PL_lex_inpat is true), a transliteration - (lex_inwhat & OP_TRANS is true), or a double-quoted string. + (PL_lex_inwhat == OP_TRANS is true), or a double-quoted string. - Returns a pointer to the character scanned up to. Iff this is - advanced from the start pointer supplied (ie if anything was + Returns a pointer to the character scanned up to. If this is + advanced from the start pointer supplied (i.e. if anything was successfully parsed), will leave an OP for the substring scanned in yylval. Caller must intuit reason for not parsing further by looking at the next characters herself. @@ -1709,21 +1767,23 @@ S_sublex_done(pTHX) backslashes: double-quoted style: \r and \n regexp special ones: \D \s - constants: \x3 - backrefs: \1 (deprecated in substitution replacements) + constants: \x31 + backrefs: \1 case and quoting: \U \Q \E stops on @ and $, but not for $ as tail anchor In transliterations: characters are VERY literal, except for - not at the start or end - of the string, which indicates a range. scan_const expands the - range to the full set of intermediate characters. + of the string, which indicates a range. If the range is in bytes, + scan_const expands the range to the full set of intermediate + characters. If the range is in utf8, the hyphen is replaced with + a certain range mark which will be handled by pmtrans() in op.c. In double-quoted strings: backslashes: double-quoted style: \r and \n - constants: \x3 - backrefs: \1 (deprecated) + constants: \x31 + deprecated backrefs: \1 (in substitution replacements) case and quoting: \U \Q \E stops on @ and $ @@ -1731,31 +1791,35 @@ S_sublex_done(pTHX) It stops processing as soon as it finds an embedded $ or @ variable and leaves it to the caller to work out what's going on. - @ in pattern could be: @foo, @{foo}, @$foo, @'foo, @::foo. + embedded arrays (whether in pattern or not) could be: + @foo, @::foo, @'foo, @{foo}, @$foo, @+, @-. + + $ in double-quoted strings must be the symbol of an embedded scalar. $ in pattern could be $foo or could be tail anchor. Assumption: it's a tail anchor if $ is the last thing in the string, or if it's - followed by one of ")| \n\t" + followed by one of "()| \r\n\t" \1 (backreferences) are turned into $1 The structure of the code is while (there's a character to process) { - handle transliteration ranges - skip regexp comments - skip # initiated comments in //x patterns - check for embedded @foo + handle transliteration ranges + skip regexp comments /(?#comment)/ and codes /(?{code})/ + skip #-initiated comments in //x patterns + check for embedded arrays check for embedded scalars if (backslash) { - leave intact backslashes from leave (below) - deprecate \1 in strings and sub replacements + leave intact backslashes from leaveit (below) + deprecate \1 in substitution replacements handle string-changing backslashes \l \U \Q \E, etc. switch (what was escaped) { - handle - in a transliteration (becomes a literal -) - handle \132 octal characters - handle 0x15 hex characters - handle \cV (control V) - handle printf backslashes (\f, \r, \n, etc) + handle \- in a transliteration (becomes a literal -) + handle \132 (octal characters) + handle \x15 and \x{1234} (hex characters) + handle \N{name} (named characters) + handle \cV (control characters) + handle printf-style backslashes (\f, \r, \n, etc) } (end switch) } (end if backslash) } (end while character to read) @@ -1777,13 +1841,9 @@ S_scan_const(pTHX_ char *start) UV uv; #ifdef EBCDIC UV literal_endpoint = 0; + bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */ #endif - const char * const leaveit = /* set of acceptably-backslashed characters */ - PL_lex_inpat - ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#" - : ""; - if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) { /* If we are doing a trans and we know we want UTF8 set expectation */ has_utf8 = PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF); @@ -1800,7 +1860,15 @@ S_scan_const(pTHX_ char *start) I32 min; /* first character in range */ I32 max; /* last character in range */ - if (has_utf8) { +#ifdef EBCDIC + UV uvmax = 0; +#endif + + if (has_utf8 +#ifdef EBCDIC + && !native_range +#endif + ) { char * const c = (char*)utf8_hop((U8*)d, -1); char *e = d++; while (e-- > c) @@ -1813,12 +1881,43 @@ S_scan_const(pTHX_ char *start) } i = d - SvPVX_const(sv); /* remember current offset */ +#ifdef EBCDIC + SvGROW(sv, + SvLEN(sv) + (has_utf8 ? + (512 - UTF_CONTINUATION_MARK + + UNISKIP(0x100)) + : 256)); + /* How many two-byte within 0..255: 128 in UTF-8, + * 96 in UTF-8-mod. */ +#else SvGROW(sv, SvLEN(sv) + 256); /* never more than 256 chars in a range */ +#endif d = SvPVX(sv) + i; /* refresh d after realloc */ - d -= 2; /* eat the first char and the - */ - - min = (U8)*d; /* first char in range */ - max = (U8)d[1]; /* last char in range */ +#ifdef EBCDIC + if (has_utf8) { + int j; + for (j = 0; j <= 1; j++) { + char * const c = (char*)utf8_hop((U8*)d, -1); + const UV uv = utf8n_to_uvchr((U8*)c, d - c, NULL, 0); + if (j) + min = (U8)uv; + else if (uv < 256) + max = (U8)uv; + else { + max = (U8)0xff; /* only to \xff */ + uvmax = uv; /* \x{100} to uvmax */ + } + d = c; /* eat endpoint chars */ + } + } + else { +#endif + d -= 2; /* eat the first char and the - */ + min = (U8)*d; /* first char in range */ + max = (U8)d[1]; /* last char in range */ +#ifdef EBCDIC + } +#endif if (min > max) { Perl_croak(aTHX_ @@ -1843,7 +1942,29 @@ S_scan_const(pTHX_ char *start) else #endif for (i = min; i <= max; i++) - *d++ = (char)i; +#ifdef EBCDIC + if (has_utf8) { + const U8 ch = (U8)NATIVE_TO_UTF(i); + if (UNI_IS_INVARIANT(ch)) + *d++ = (U8)i; + else { + *d++ = (U8)UTF8_EIGHT_BIT_HI(ch); + *d++ = (U8)UTF8_EIGHT_BIT_LO(ch); + } + } + else +#endif + *d++ = (char)i; + +#ifdef EBCDIC + if (uvmax) { + d = (char*)uvchr_to_utf8((U8*)d, 0x100); + if (uvmax > 0x101) + *d++ = (char)UTF_TO_NATIVE(0xff); + if (uvmax > 0x100) + d = (char*)uvchr_to_utf8((U8*)d, uvmax); + } +#endif /* mark the range as done, and continue */ dorange = FALSE; @@ -1859,7 +1980,11 @@ S_scan_const(pTHX_ char *start) if (didrange) { Perl_croak(aTHX_ "Ambiguous range in transliteration operator"); } - if (has_utf8) { + if (has_utf8 +#ifdef EBCDIC + && !native_range +#endif + ) { *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */ s++; continue; @@ -1871,6 +1996,7 @@ S_scan_const(pTHX_ char *start) didrange = FALSE; #ifdef EBCDIC literal_endpoint = 0; + native_range = TRUE; #endif } } @@ -1917,9 +2043,14 @@ S_scan_const(pTHX_ char *start) /* check for embedded arrays (@foo, @::foo, @'foo, @{foo}, @$foo, @+, @-) */ - else if (*s == '@' && s[1] - && (isALNUM_lazy_if(s+1,UTF) || strchr(":'{$+-", s[1]))) - break; + else if (*s == '@' && s[1]) { + if (isALNUM_lazy_if(s+1,UTF)) + break; + if (strchr(":'{$", s[1])) + break; + if (!PL_lex_inpat && (s[1] == '+' || s[1] == '-')) + break; /* in regexp, neither @+ nor @- are interpolated */ + } /* check for embedded scalars. only stop if we're sure it's a variable. @@ -1937,13 +2068,6 @@ S_scan_const(pTHX_ char *start) if (*s == '\\' && s+1 < send) { s++; - /* some backslashes we leave behind */ - if (*leaveit && *s && strchr(leaveit, *s)) { - *d++ = NATIVE_TO_NEED(has_utf8,'\\'); - *d++ = NATIVE_TO_NEED(has_utf8,*s++); - continue; - } - /* deprecate \1 in strings and substitution replacements */ if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat && isDIGIT(*s) && *s != '0' && !isDIGIT(s[1])) @@ -1959,6 +2083,11 @@ S_scan_const(pTHX_ char *start) --s; break; } + /* skip any other backslash escapes in a pattern */ + else if (PL_lex_inpat) { + *d++ = NATIVE_TO_NEED(has_utf8,'\\'); + goto default_action; + } /* if we get here, it's either a quoted -, or a digit */ switch (*s) { @@ -1972,12 +2101,11 @@ S_scan_const(pTHX_ char *start) /* FALL THROUGH */ default: { - if (isALNUM(*s) && - *s != '_' && + if ((isALPHA(*s) || isDIGIT(*s)) && ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), - "Unrecognized escape \\%c passed through", - *s); + "Unrecognized escape \\%c passed through", + *s); /* default action is to copy the quoted character */ goto default_action; } @@ -2075,6 +2203,10 @@ S_scan_const(pTHX_ char *start) (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF); } +#ifdef EBCDIC + if (uv > 255 && !dorange) + native_range = FALSE; +#endif } else { *d++ = (char)uv; @@ -2093,6 +2225,7 @@ S_scan_const(pTHX_ char *start) SV *res; STRLEN len; const char *str; + SV *type; if (!e) { yyerror("Missing right brace on \\N{}"); @@ -2106,12 +2239,17 @@ S_scan_const(pTHX_ char *start) s += 3; len = e - s; uv = grok_hex(s, &len, &flags, NULL); + if ( e > s && len != (STRLEN)(e - s) ) { + uv = 0xFFFD; + } s = e + 1; goto NUM_ESCAPE_INSERT; } res = newSVpvn(s + 1, e - s - 1); + type = newSVpvn(s - 2,e - s + 3); res = new_constant( NULL, 0, "charnames", - res, NULL, "\\N{...}" ); + res, NULL, SvPVX(type) ); + SvREFCNT_dec(type); if (has_utf8) sv_utf8_upgrade(res); str = SvPV_const(res,len); @@ -2152,6 +2290,10 @@ S_scan_const(pTHX_ char *start) SvGROW(sv, (SvLEN(sv) + len - (e - s + 4))); d = SvPVX(sv) + (d - odest); } +#ifdef EBCDIC + if (!dorange) + native_range = FALSE; /* \N{} is guessed to be Unicode */ +#endif Copy(str, d, len, char); d += len; SvREFCNT_dec(res); @@ -2225,6 +2367,10 @@ S_scan_const(pTHX_ char *start) } d = (char*)uvchr_to_utf8((U8*)d, nextuv); has_utf8 = TRUE; +#ifdef EBCDIC + if (uv > 255 && !dorange) + native_range = FALSE; +#endif } else { *d++ = NATIVE_TO_NEED(has_utf8,*s++); @@ -2259,13 +2405,15 @@ S_scan_const(pTHX_ char *start) /* return the substring (via yylval) only if we parsed anything */ if (s > PL_bufptr) { if ( PL_hints & ( PL_lex_inpat ? HINT_NEW_RE : HINT_NEW_STRING ) ) - sv = new_constant(start, s - start, (PL_lex_inpat ? "qr" : "q"), + sv = new_constant(start, s - start, + (const char *)(PL_lex_inpat ? "qr" : "q"), sv, NULL, - ( PL_lex_inwhat == OP_TRANS - ? "tr" - : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) - ? "s" - : "qq"))); + (const char *) + (( PL_lex_inwhat == OP_TRANS + ? "tr" + : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) + ? "s" + : "qq")))); yylval.opval = (OP*)newSVOP(OP_CONST, 0, sv); } else SvREFCNT_dec(sv); @@ -2380,7 +2528,7 @@ S_intuit_more(pTHX_ register char *s) if (s[1]) { if (strchr("wds]",s[1])) weight += 100; - else if (seen['\''] || seen['"']) + else if (seen[(U8)'\''] || seen[(U8)'"']) weight += 1; else if (strchr("rnftbxcav",s[1])) weight += 40; @@ -2412,7 +2560,7 @@ S_intuit_more(pTHX_ register char *s) while (isALPHA(*s)) *d++ = *s++; *d = '\0'; - if (keyword(tmpbuf, d - tmpbuf)) + if (keyword(tmpbuf, d - tmpbuf, 0)) weight -= 150; } if (un_char == last_un_char + 1) @@ -2476,7 +2624,7 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) } } } else - gv = 0; + gv = NULL; } s = scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); /* start is the beginning of the possible filehandle/object, @@ -2491,14 +2639,14 @@ S_intuit_method(pTHX_ char *start, GV *gv, CV *cv) len = start - SvPVX(PL_linestr); #endif s = PEEKSPACE(s); -#ifdef PERLMAD +#ifdef PERL_MAD start = SvPVX(PL_linestr) + len; #endif PL_bufptr = start; PL_expect = XREF; return *s == '(' ? FUNCMETH : METHOD; } - if (!keyword(tmpbuf, len)) { + if (!keyword(tmpbuf, len, 0)) { if (len > 2 && tmpbuf[len - 2] == ':' && tmpbuf[len - 1] == ':') { len -= 2; tmpbuf[len] = '\0'; @@ -2592,7 +2740,8 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) IoANY(datasv) = FPTR2DPTR(void *, funcp); /* stash funcp into spare field */ IoFLAGS(datasv) |= IOf_FAKE_DIRP; DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n", - IoANY(datasv), SvPV_nolen(datasv))); + FPTR2DPTR(void *, IoANY(datasv)), + SvPV_nolen(datasv))); av_unshift(PL_rsfp_filters, 1); av_store(PL_rsfp_filters, 0, datasv) ; return(datasv); @@ -2607,7 +2756,8 @@ Perl_filter_del(pTHX_ filter_t funcp) SV *datasv; #ifdef DEBUGGING - DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", FPTR2DPTR(XPVIO *, funcp))); + DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", + FPTR2DPTR(void*, funcp))); #endif if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0) return; @@ -2633,6 +2783,17 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) dVAR; filter_t funcp; SV *datasv = NULL; + /* This API is bad. It should have been using unsigned int for maxlen. + Not sure if we want to change the API, but if not we should sanity + check the value here. */ + const unsigned int correct_length + = maxlen < 0 ? +#ifdef PERL_MICRO + 0x7FFFFFFF +#else + INT_MAX +#endif + : maxlen; if (!PL_rsfp_filters) return -1; @@ -2641,14 +2802,15 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) /* Note that we append to the line. This is handy. */ DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: from rsfp\n", idx)); - if (maxlen) { + if (correct_length) { /* Want a block */ int len ; const int old_len = SvCUR(buf_sv); /* ensure buf_sv is large enough */ - SvGROW(buf_sv, (STRLEN)(old_len + maxlen)) ; - if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){ + SvGROW(buf_sv, (STRLEN)(old_len + correct_length)) ; + if ((len = PerlIO_read(PL_rsfp, SvPVX(buf_sv) + old_len, + correct_length)) <= 0) { if (PerlIO_error(PL_rsfp)) return -1; /* error */ else @@ -2671,17 +2833,17 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: skipped (filter deleted)\n", idx)); - return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */ + return FILTER_READ(idx+1, buf_sv, correct_length); /* recurse */ } /* Get function pointer hidden within datasv */ funcp = DPTR2FPTR(filter_t, IoANY(datasv)); DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: via function %p (%s)\n", - idx, datasv, SvPV_nolen_const(datasv))); + idx, (void*)datasv, SvPV_nolen_const(datasv))); /* Call function. The function is expected to */ /* call "FILTER_READ(idx+1, buf_sv)" first. */ /* Return: <0:error, =0:eof, >0:not eof */ - return (*funcp)(aTHX_ idx, buf_sv, maxlen); + return (*funcp)(aTHX_ idx, buf_sv, correct_length); } STATIC char * @@ -2722,16 +2884,44 @@ S_find_in_my_stash(pTHX_ const char *pkgname, I32 len) } /* use constant CLASS => 'MyClass' */ - if ((gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV))) { - SV *sv; - if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) { + gv = gv_fetchpvn_flags(pkgname, len, 0, SVt_PVCV); + if (gv && GvCV(gv)) { + SV * const sv = cv_const_sv(GvCV(gv)); + if (sv) pkgname = SvPV_nolen_const(sv); - } } return gv_stashpv(pkgname, FALSE); } +/* + * S_readpipe_override + * Check whether readpipe() is overriden, and generates the appropriate + * optree, provided sublex_start() is called afterwards. + */ +STATIC void +S_readpipe_override(pTHX) +{ + GV **gvp; + GV *gv_readpipe = gv_fetchpvs("readpipe", GV_NOTQUAL, SVt_PVCV); + yylval.ival = OP_BACKTICK; + if ((gv_readpipe + && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe)) + || + ((gvp = (GV**)hv_fetchs(PL_globalstash, "readpipe", FALSE)) + && (gv_readpipe = *gvp) != (GV*)&PL_sv_undef + && GvCVu(gv_readpipe) && GvIMPORTED_CV(gv_readpipe))) + { + PL_lex_op = (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, + newSVOP(OP_CONST, 0, &PL_sv_undef), /* value will be read later */ + newCVREF(0, newGVOP(OP_GV, 0, gv_readpipe)))); + } + else { + set_csh(); + } +} + #ifdef PERL_MAD /* * Perl_madlex @@ -2770,9 +2960,9 @@ Perl_madlex(pTHX) if (!PL_thismad || PL_thismad->mad_key == '^') { /* not forced already? */ if (!PL_thistoken) { if (PL_realtokenstart < 0 || !CopLINE(PL_curcop)) - PL_thistoken = newSVpvn("",0); + PL_thistoken = newSVpvs(""); else { - char *tstart = SvPVX(PL_linestr) + PL_realtokenstart; + char * const tstart = SvPVX(PL_linestr) + PL_realtokenstart; PL_thistoken = newSVpvn(tstart, s - tstart); } } @@ -2988,6 +3178,13 @@ Perl_yylex(pTHX) STRLEN len; bool bof = FALSE; + /* orig_keyword, gvp, and gv are initialized here because + * jump to the label just_a_word_zero can bypass their + * initialization later. */ + I32 orig_keyword = 0; + GV *gv = NULL; + GV **gvp = NULL; + DEBUG_T( { SV* tmp = newSVpvs(""); PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n", @@ -3069,7 +3266,7 @@ Perl_yylex(pTHX) PL_lex_state = LEX_INTERPCONCAT; #ifdef PERL_MAD if (PL_madskills) - PL_thistoken = newSVpvn("\\E",2); + PL_thistoken = newSVpvs("\\E"); #endif } return REPORT(')'); @@ -3078,7 +3275,7 @@ Perl_yylex(pTHX) while (PL_bufptr != PL_bufend && PL_bufptr[0] == '\\' && PL_bufptr[1] == 'E') { if (!PL_thiswhite) - PL_thiswhite = newSVpvn("",0); + PL_thiswhite = newSVpvs(""); sv_catpvn(PL_thiswhite, PL_bufptr, 2); PL_bufptr += 2; } @@ -3096,7 +3293,7 @@ Perl_yylex(pTHX) if (s[1] == '\\' && s[2] == 'E') { #ifdef PERL_MAD if (!PL_thiswhite) - PL_thiswhite = newSVpvn("",0); + PL_thiswhite = newSVpvs(""); sv_catpvn(PL_thiswhite, PL_bufptr, 4); #endif PL_bufptr = s + 3; @@ -3135,7 +3332,7 @@ Perl_yylex(pTHX) else Perl_croak(aTHX_ "panic: yylex"); if (PL_madskills) { - SV* const tmpsv = newSVpvn("",0); + SV* const tmpsv = newSVpvs(""); Perl_sv_catpvf(aTHX_ tmpsv, "\\%c", *s); curmad('_', tmpsv); } @@ -3149,7 +3346,7 @@ Perl_yylex(pTHX) if (PL_madskills) { if (PL_thistoken) sv_free(PL_thistoken); - PL_thistoken = newSVpvn("",0); + PL_thistoken = newSVpvs(""); } #endif /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ @@ -3195,7 +3392,7 @@ Perl_yylex(pTHX) if (PL_madskills) { if (PL_thistoken) sv_free(PL_thistoken); - PL_thistoken = newSVpvn("",0); + PL_thistoken = newSVpvs(""); } #endif /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ @@ -3221,7 +3418,7 @@ Perl_yylex(pTHX) if (PL_madskills) { if (PL_thistoken) sv_free(PL_thistoken); - PL_thistoken = newSVpvn("",0); + PL_thistoken = newSVpvs(""); } #endif return REPORT(')'); @@ -3272,7 +3469,7 @@ Perl_yylex(pTHX) if (PL_madskills) { if (PL_thistoken) sv_free(PL_thistoken); - PL_thistoken = newSVpvn("",0); + PL_thistoken = newSVpvs(""); } #endif /* commas only at base level: /$a\Ub$c/ => ($a,uc(b.$c)) */ @@ -3325,9 +3522,10 @@ Perl_yylex(pTHX) PL_last_uni = 0; PL_last_lop = 0; if (PL_lex_brackets) { - yyerror(PL_lex_formbrack - ? "Format not terminated" - : "Missing right curly or square bracket"); + yyerror((const char *) + (PL_lex_formbrack + ? "Format not terminated" + : "Missing right curly or square bracket")); } DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Tokener got EOF\n"); @@ -3394,15 +3592,8 @@ Perl_yylex(pTHX) PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = NULL; - if (PERLDB_LINE && PL_curstash != PL_debstash) { - SV * const sv = newSV(0); - - sv_upgrade(sv, SVt_PVMG); - sv_setsv(sv,PL_linestr); - (void)SvIOK_on(sv); - SvIV_set(sv, 0); - av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv); - } + if (PERLDB_LINE && PL_curstash != PL_debstash) + update_debugger_info(PL_linestr, NULL, 0); goto retry; } do { @@ -3427,8 +3618,10 @@ Perl_yylex(pTHX) if (PL_madskills) PL_faketokens = 1; #endif - sv_setpv(PL_linestr,PL_minus_p - ? ";}continue{print;}" : ";}"); + sv_setpv(PL_linestr, + (const char *) + (PL_minus_p + ? ";}continue{print;}" : ";}")); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = NULL; @@ -3481,7 +3674,7 @@ Perl_yylex(pTHX) if (PL_madskills) sv_catsv(PL_thiswhite, PL_linestr); #endif - if (*s == '=' && strnEQ(s, "=cut", 4)) { + if (*s == '=' && strnEQ(s, "=cut", 4) && !isALPHA(s[4])) { sv_setpvn(PL_linestr, "", 0); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); @@ -3492,15 +3685,8 @@ Perl_yylex(pTHX) incline(s); } while (PL_doextract); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s; - if (PERLDB_LINE && PL_curstash != PL_debstash) { - SV * const sv = newSV(0); - - sv_upgrade(sv, SVt_PVMG); - sv_setsv(sv,PL_linestr); - (void)SvIOK_on(sv); - SvIV_set(sv, 0); - av_store(CopFILEAVx(PL_curcop),(I32)CopLINE(PL_curcop),sv); - } + if (PERLDB_LINE && PL_curstash != PL_debstash) + update_debugger_info(PL_linestr, NULL, 0); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = NULL; if (CopLINE(PL_curcop) == 1) { @@ -3642,8 +3828,10 @@ Perl_yylex(pTHX) } #endif if (d) { - while (*d && !isSPACE(*d)) d++; - while (SPACE_OR_TAB(*d)) d++; + while (*d && !isSPACE(*d)) + d++; + while (SPACE_OR_TAB(*d)) + d++; if (*d++ == '-') { const bool switches_done = PL_doswitches; @@ -3770,7 +3958,7 @@ Perl_yylex(pTHX) Perl_croak(aTHX_ "panic: input overflow"); if (PL_madskills && CopLINE(PL_curcop) >= 1) { if (!PL_thiswhite) - PL_thiswhite = newSVpvn("",0); + PL_thiswhite = newSVpvs(""); if (CopLINE(PL_curcop) == 1) { sv_setpvn(PL_thiswhite, "", 0); PL_faketokens = 0; @@ -3802,9 +3990,7 @@ Perl_yylex(pTHX) if (strnEQ(s,"=>",2)) { s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE); - DEBUG_T( { S_printbuf(aTHX_ - "### Saw unary minus before =>, forcing word %s\n", s); - } ); + DEBUG_T( { printbuf("### Saw unary minus before =>, forcing word %s\n", s); } ); OPERATOR('-'); /* unary minus */ } PL_last_uni = PL_oldbufptr; @@ -3988,8 +4174,9 @@ Perl_yylex(pTHX) attrs = NULL; while (isIDFIRST_lazy_if(s,UTF)) { I32 tmp; + SV *sv; d = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); - if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len))) { + if (isLOWER(*s) && (tmp = keyword(PL_tokenbuf, len, 0))) { if (tmp < 0) tmp = -tmp; switch (tmp) { case KEY_or: @@ -4005,6 +4192,7 @@ Perl_yylex(pTHX) break; } } + sv = newSVpvn(s, len); if (*d == '(') { d = scan_str(d,TRUE,TRUE); if (!d) { @@ -4015,11 +4203,11 @@ Perl_yylex(pTHX) yyerror("Unterminated attribute parameter in attribute list"); if (attrs) op_free(attrs); + sv_free(sv); return REPORT(0); /* EOF indicator */ } } if (PL_lex_stuff) { - SV *sv = newSVpvn(s, len); sv_catsv(sv, PL_lex_stuff); attrs = append_elem(OP_LIST, attrs, newSVOP(OP_CONST, 0, sv)); @@ -4027,7 +4215,8 @@ Perl_yylex(pTHX) PL_lex_stuff = NULL; } else { - if (len == 6 && strnEQ(s, "unique", len)) { + if (len == 6 && strnEQ(SvPVX(sv), "unique", len)) { + sv_free(sv); if (PL_in_my == KEY_our) { #ifdef USE_ITHREADS GvUNIQUE_on(cGVOPx_gv(yylval.opval)); @@ -4042,14 +4231,22 @@ Perl_yylex(pTHX) /* NOTE: any CV attrs applied here need to be part of the CVf_BUILTIN_ATTRS define in cv.h! */ - else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len)) + else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "lvalue", len)) { + sv_free(sv); CvLVALUE_on(PL_compcv); - else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len)) + } + else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "locked", len)) { + sv_free(sv); CvLOCKED_on(PL_compcv); - else if (!PL_in_my && len == 6 && strnEQ(s, "method", len)) + } + else if (!PL_in_my && len == 6 && strnEQ(SvPVX(sv), "method", len)) { + sv_free(sv); CvMETHOD_on(PL_compcv); - else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len)) + } + else if (!PL_in_my && len == 9 && strnEQ(SvPVX(sv), "assertion", len)) { + sv_free(sv); CvASSERTION_on(PL_compcv); + } /* After we've set the flags, it could be argued that we don't need to do the attributes.pm-based setting process, and shouldn't bother appending recognized @@ -4063,7 +4260,7 @@ Perl_yylex(pTHX) else attrs = append_elem(OP_LIST, attrs, newSVOP(OP_CONST, 0, - newSVpvn(s, len))); + sv)); } s = PEEKSPACE(d); if (*s == ':' && s[1] != ':') @@ -4088,10 +4285,11 @@ Perl_yylex(pTHX) context messages from yyerror(). */ PL_bufptr = s; - yyerror( *s - ? Perl_form(aTHX_ "Invalid separator character " - "%c%c%c in attribute list", q, *s, q) - : "Unterminated attribute list" ); + yyerror( (const char *) + (*s + ? Perl_form(aTHX_ "Invalid separator character " + "%c%c%c in attribute list", q, *s, q) + : "Unterminated attribute list" ) ); if (attrs) op_free(attrs); OPERATOR(':'); @@ -4328,7 +4526,7 @@ Perl_yylex(pTHX) #if 0 if (PL_madskills) { if (!PL_thiswhite) - PL_thiswhite = newSVpvn("",0); + PL_thiswhite = newSVpvs(""); sv_catpvn(PL_thiswhite,"}",1); } #endif @@ -4353,7 +4551,7 @@ Perl_yylex(pTHX) force_next('}'); #ifdef PERL_MAD if (!PL_thistoken) - PL_thistoken = newSVpvn("",0); + PL_thistoken = newSVpvs(""); #endif TOKEN(';'); case '&': @@ -4427,7 +4625,7 @@ Perl_yylex(pTHX) #ifdef PERL_MAD if (PL_madskills) { if (!PL_thiswhite) - PL_thiswhite = newSVpvn("",0); + PL_thiswhite = newSVpvs(""); sv_catpvn(PL_thiswhite, PL_linestart, PL_bufend - PL_linestart); } @@ -4438,12 +4636,13 @@ Perl_yylex(pTHX) } } if (PL_lex_brackets < PL_lex_formbrack) { - const char *t; + const char *t = s; #ifdef PERL_STRICT_CR - for (t = s; SPACE_OR_TAB(*t); t++) ; + while (SPACE_OR_TAB(*t)) #else - for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ; + while (SPACE_OR_TAB(*t) || *t == '\r') #endif + t++; if (*t == '\n' || *t == '#') { s--; PL_expect = XBLOCK; @@ -4571,10 +4770,10 @@ Perl_yylex(pTHX) if (*s == '[') { PL_tokenbuf[0] = '@'; if (ckWARN(WARN_SYNTAX)) { - char *t; - for(t = s + 1; - isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$'; - t++) ; + char *t = s+1; + + while (isSPACE(*t) || isALNUM_lazy_if(t,UTF) || *t == '$') + t++; if (*t++ == ',') { PL_bufptr = PEEKSPACE(PL_bufptr); /* XXX can realloc */ while (t < PL_bufend && *t != ']') @@ -4592,13 +4791,16 @@ Perl_yylex(pTHX) && (t = strchr(s, '}')) && (t = strchr(t, '='))) { char tmpbuf[sizeof PL_tokenbuf]; - for (t++; isSPACE(*t); t++) ; + do { + t++; + } while (isSPACE(*t)); if (isIDFIRST_lazy_if(t,UTF)) { - STRLEN dummylen; + STRLEN len; t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, - &dummylen); - for (; isSPACE(*t); t++) ; - if (*t == ';' && get_cv(tmpbuf, FALSE)) + &len); + while (isSPACE(*t)) + t++; + if (*t == ';' && get_cvn_flags(tmpbuf, len, 0)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "You need to quote \"%s\"", tmpbuf); @@ -4620,7 +4822,7 @@ Perl_yylex(pTHX) char tmpbuf[sizeof PL_tokenbuf]; int t2; scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); - if ((t2 = keyword(tmpbuf, len))) { + if ((t2 = keyword(tmpbuf, len, 0))) { /* binary operators exclude handle interpretations */ switch (t2) { case -KEY_x: @@ -4763,14 +4965,14 @@ Perl_yylex(pTHX) case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': s = scan_num(s, &yylval); - DEBUG_T( { S_printbuf(aTHX_ "### Saw number in %s\n", s); } ); + DEBUG_T( { printbuf("### Saw number in %s\n", s); } ); if (PL_expect == XOPERATOR) no_op("Number",s); TERM(THING); case '\'': s = scan_str(s,!!PL_madskills,FALSE); - DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } ); + DEBUG_T( { printbuf("### Saw string before %s\n", s); } ); if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; @@ -4787,7 +4989,7 @@ Perl_yylex(pTHX) case '"': s = scan_str(s,!!PL_madskills,FALSE); - DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } ); + DEBUG_T( { printbuf("### Saw string before %s\n", s); } ); if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; @@ -4812,13 +5014,12 @@ Perl_yylex(pTHX) case '`': s = scan_str(s,!!PL_madskills,FALSE); - DEBUG_T( { S_printbuf(aTHX_ "### Saw backtick string before %s\n", s); } ); + DEBUG_T( { printbuf("### Saw backtick string before %s\n", s); } ); if (PL_expect == XOPERATOR) no_op("Backticks",s); if (!s) missingterm(NULL); - yylval.ival = OP_BACKTICK; - set_csh(); + readpipe_override(); TERM(sublex_start()); case '\\': @@ -4893,9 +5094,10 @@ Perl_yylex(pTHX) keylookup: { I32 tmp; - I32 orig_keyword = 0; - GV *gv = NULL; - GV **gvp = NULL; + + orig_keyword = 0; + gv = NULL; + gvp = NULL; PL_bufptr = s; s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); @@ -4918,13 +5120,13 @@ Perl_yylex(pTHX) if (!tmp && PL_expect == XSTATE && d < PL_bufend && *d == ':' && *(d + 1) != ':') { s = d + 1; - yylval.pval = savepv(PL_tokenbuf); + yylval.pval = CopLABEL_alloc(PL_tokenbuf); CLINE; TOKEN(LABEL); } /* Check for keywords */ - tmp = keyword(PL_tokenbuf, len); + tmp = keyword(PL_tokenbuf, len, 0); /* Is this a word before a => operator? */ if (*d == '=' && d[1] == '>') { @@ -5173,7 +5375,9 @@ Perl_yylex(pTHX) if (*s == '(') { CLINE; if (cv) { - for (d = s + 1; SPACE_OR_TAB(*d); d++) ; + d = s + 1; + while (SPACE_OR_TAB(*d)) + d++; if (*d == ')' && (sv = gv_const_sv(gv))) { s = d + 1; #ifdef PERL_MAD @@ -5202,7 +5406,7 @@ Perl_yylex(pTHX) if (PL_madskills) { PL_nextwhite = nextPL_nextwhite; curmad('X', PL_thistoken); - PL_thistoken = newSVpvn("",0); + PL_thistoken = newSVpvs(""); } #endif force_next(WORD); @@ -5260,18 +5464,21 @@ Perl_yylex(pTHX) #ifdef PERL_MAD cv && #endif - SvPOK(cv)) { + SvPOK(cv)) + { STRLEN protolen; const char *proto = SvPV_const((SV*)cv, protolen); if (!protolen) TERM(FUNC0SUB); - if (*proto == '$' && proto[1] == '\0') + if ((*proto == '$' || *proto == '_') && proto[1] == '\0') OPERATOR(UNIOPSUB); while (*proto == ';') proto++; if (*proto == '&' && *s == '{') { - sv_setpv(PL_subname, PL_curstash ? - "__ANON__" : "__ANON__::__ANON__"); + sv_setpv(PL_subname, + (const char *) + (PL_curstash ? + "__ANON__" : "__ANON__::__ANON__")); PREBLOCK(LSTOPSUB); } } @@ -5287,7 +5494,7 @@ Perl_yylex(pTHX) if (PL_madskills) { PL_nextwhite = nextPL_nextwhite; curmad('X', PL_thistoken); - PL_thistoken = newSVpvn("",0); + PL_thistoken = newSVpvs(""); } force_next(WORD); TOKEN(NOAMP); @@ -5304,7 +5511,7 @@ Perl_yylex(pTHX) STRLEN tmplen; d = s; d = scan_word(d, tmpbuf, sizeof tmpbuf, TRUE, &tmplen); - if (!keyword(tmpbuf,tmplen)) + if (!keyword(tmpbuf, tmplen, 0)) probable_sub = 1; else { while (d < PL_bufend && isSPACE(*d)) @@ -5327,7 +5534,7 @@ Perl_yylex(pTHX) PL_expect = XTERM; PL_nextwhite = nextPL_nextwhite; curmad('X', PL_thistoken); - PL_thistoken = newSVpvn("",0); + PL_thistoken = newSVpvs(""); force_next(WORD); TOKEN(NOAMP); } @@ -5347,7 +5554,9 @@ Perl_yylex(pTHX) bareword: if (lastchar != '-') { if (ckWARN(WARN_RESERVED)) { - for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ; + d = PL_tokenbuf; + while (isLOWER(*d)) + d++; if (!*d && !gv_stashpv(PL_tokenbuf,FALSE)) Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved, PL_tokenbuf); @@ -5459,7 +5668,7 @@ Perl_yylex(pTHX) PUTBACK; PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, Perl_form(aTHX_ ":encoding(%"SVf")", - name)); + SVfARG(name))); FREETMPS; LEAVE; } @@ -5470,7 +5679,7 @@ Perl_yylex(pTHX) if (PL_realtokenstart >= 0) { char *tstart = SvPVX(PL_linestr) + PL_realtokenstart; if (!PL_endwhite) - PL_endwhite = newSVpvn("",0); + PL_endwhite = newSVpvs(""); sv_catsv(PL_endwhite, PL_thiswhite); PL_thiswhite = 0; sv_catpvn(PL_endwhite, tstart, PL_bufend - tstart); @@ -5488,6 +5697,7 @@ Perl_yylex(pTHX) case KEY_AUTOLOAD: case KEY_DESTROY: case KEY_BEGIN: + case KEY_UNITCHECK: case KEY_CHECK: case KEY_INIT: case KEY_END: @@ -5502,7 +5712,7 @@ Perl_yylex(pTHX) s += 2; d = s; s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); - if (!(tmp = keyword(PL_tokenbuf, len))) + if (!(tmp = keyword(PL_tokenbuf, len, 0))) Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf); if (tmp < 0) tmp = -tmp; @@ -5939,6 +6149,7 @@ Perl_yylex(pTHX) case KEY_our: case KEY_my: + case KEY_state: PL_in_my = tmp; s = SKIPSPACE1(s); if (isIDFIRST_lazy_if(s,UTF)) { @@ -5952,7 +6163,7 @@ Perl_yylex(pTHX) if (!PL_in_my_stash) { char tmpbuf[1024]; PL_bufptr = s; - sprintf(tmpbuf, "No such class %.1000s", PL_tokenbuf); + my_snprintf(tmpbuf, sizeof(tmpbuf), "No such class %.1000s", PL_tokenbuf); yyerror(tmpbuf); } #ifdef PERL_MAD @@ -5987,8 +6198,10 @@ Perl_yylex(pTHX) s = SKIPSPACE1(s); if (isIDFIRST_lazy_if(s,UTF)) { const char *t; - for (d = s; isALNUM_lazy_if(d,UTF); d++) ; - for (t=d; *t && isSPACE(*t); t++) ; + for (d = s; isALNUM_lazy_if(d,UTF);) + d++; + for (t=d; isSPACE(*t);) + t++; if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE) /* [perl #16184] */ && !(t[0] == '=' && t[1] == '>') @@ -6125,8 +6338,7 @@ Perl_yylex(pTHX) s = scan_str(s,!!PL_madskills,FALSE); if (!s) missingterm(NULL); - yylval.ival = OP_BACKTICK; - set_csh(); + readpipe_override(); TERM(sublex_start()); case KEY_return: @@ -6343,7 +6555,7 @@ Perl_yylex(pTHX) char tmpbuf[sizeof PL_tokenbuf]; SSize_t tboffset = 0; expectation attrful; - bool have_name, have_proto, bad_proto; + bool have_name, have_proto; const int key = tmp; #ifdef PERL_MAD @@ -6423,6 +6635,8 @@ Perl_yylex(pTHX) /* Look for a prototype */ if (*s == '(') { char *p; + bool bad_proto = FALSE; + const bool warnsyntax = ckWARN(WARN_SYNTAX); s = scan_str(s,!!PL_madskills,FALSE); if (!s) @@ -6430,19 +6644,18 @@ Perl_yylex(pTHX) /* strip spaces and check for bad characters */ d = SvPVX(PL_lex_stuff); tmp = 0; - bad_proto = FALSE; for (p = d; *p; ++p) { if (!isSPACE(*p)) { d[tmp++] = *p; - if (!strchr("$@%*;[]&\\", *p)) + if (warnsyntax && !strchr("$@%*;[]&\\_", *p)) bad_proto = TRUE; } } d[tmp] = '\0'; - if (bad_proto && ckWARN(WARN_SYNTAX)) + if (bad_proto) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Illegal character in prototype for %"SVf" : %s", - PL_subname, d); + SVfARG(PL_subname), d); SvCUR_set(PL_lex_stuff, tmp); have_proto = TRUE; @@ -6471,14 +6684,14 @@ Perl_yylex(pTHX) if (!have_name) Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine"); else if (*s != ';') - Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname); + Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, SVfARG(PL_subname)); } #ifdef PERL_MAD start_force(0); if (tmpwhite) { if (PL_madskills) - curmad('^', newSVpvn("",0)); + curmad('^', newSVpvs("")); CURMAD('_', tmpwhite); } force_next(0); @@ -6494,7 +6707,8 @@ Perl_yylex(pTHX) #endif if (!have_name) { sv_setpv(PL_subname, - PL_curstash ? "__ANON__" : "__ANON__::__ANON__"); + (const char *) + (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")); TOKEN(ANONSUB); } #ifndef PERL_MAD @@ -6658,7 +6872,7 @@ S_pending_ident(pTHX) { dVAR; register char *d; - register I32 tmp = 0; + PADOFFSET tmp = 0; /* pit holds the identifier we read and pending_ident is reset */ char pit = PL_pending_ident; PL_pending_ident = 0; @@ -6683,7 +6897,8 @@ S_pending_ident(pTHX) } else { if (strchr(PL_tokenbuf,':')) - yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf)); + yyerror(Perl_form(aTHX_ PL_no_myglob, + PL_in_my == KEY_my ? "my" : "state", PL_tokenbuf)); yylval.opval = newOP(OP_PADANY, 0); yylval.opval->op_targ = allocmy(PL_tokenbuf); @@ -6799,9 +7014,9 @@ S_pending_ident(pTHX) */ I32 -Perl_keyword (pTHX_ const char *name, I32 len) +Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords) { - dVAR; + dVAR; switch (len) { case 1: /* 5 tokens of length 1 */ @@ -7071,7 +7286,7 @@ Perl_keyword (pTHX_ const char *name, I32 len) case 'r': if (name[2] == 'r') { /* err */ - return (FEATURE_IS_ENABLED("err") ? -KEY_err : 0); + return (all_keywords || FEATURE_IS_ENABLED("err") ? -KEY_err : 0); } goto unknown; @@ -7210,7 +7425,7 @@ Perl_keyword (pTHX_ const char *name, I32 len) case 'a': if (name[2] == 'y') { /* say */ - return (FEATURE_IS_ENABLED("say") ? -KEY_say : 0); + return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0); } goto unknown; @@ -7708,46 +7923,46 @@ Perl_keyword (pTHX_ const char *name, I32 len) switch (name[1]) { case 'a': - switch (name[2]) - { - case 'i': - if (name[3] == 't') - { /* wait */ - return -KEY_wait; - } + switch (name[2]) + { + case 'i': + if (name[3] == 't') + { /* wait */ + return -KEY_wait; + } - goto unknown; + goto unknown; - case 'r': - if (name[3] == 'n') - { /* warn */ - return -KEY_warn; - } + case 'r': + if (name[3] == 'n') + { /* warn */ + return -KEY_warn; + } - goto unknown; + goto unknown; - default: - goto unknown; - } + default: + goto unknown; + } case 'h': if (name[2] == 'e' && name[3] == 'n') { /* when */ - return (FEATURE_IS_ENABLED("switch") ? KEY_when : 0); - } + return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_when : 0); + } - goto unknown; + goto unknown; - default: - goto unknown; - } + default: + goto unknown; + } default: goto unknown; } - case 5: /* 38 tokens of length 5 */ + case 5: /* 39 tokens of length 5 */ switch (name[0]) { case 'B': @@ -7804,20 +8019,20 @@ Perl_keyword (pTHX_ const char *name, I32 len) { case 'l': if (name[2] == 'e' && - name[3] == 's' && - name[4] == 's') - { /* bless */ - return -KEY_bless; - } + name[3] == 's' && + name[4] == 's') + { /* bless */ + return -KEY_bless; + } - goto unknown; + goto unknown; case 'r': if (name[2] == 'e' && name[3] == 'a' && name[4] == 'k') { /* break */ - return (FEATURE_IS_ENABLED("switch") ? -KEY_break : 0); + return (all_keywords || FEATURE_IS_ENABLED("switch") ? -KEY_break : 0); } goto unknown; @@ -7945,7 +8160,7 @@ Perl_keyword (pTHX_ const char *name, I32 len) name[3] == 'e' && name[4] == 'n') { /* given */ - return (FEATURE_IS_ENABLED("switch") ? KEY_given : 0); + return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_given : 0); } goto unknown; @@ -8107,14 +8322,29 @@ Perl_keyword (pTHX_ const char *name, I32 len) goto unknown; case 't': - if (name[2] == 'u' && - name[3] == 'd' && - name[4] == 'y') - { /* study */ - return KEY_study; - } + switch (name[2]) + { + case 'a': + if (name[3] == 't' && + name[4] == 'e') + { /* state */ + return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0); + } - goto unknown; + goto unknown; + + case 'u': + if (name[3] == 'd' && + name[4] == 'y') + { /* study */ + return KEY_study; + } + + goto unknown; + + default: + goto unknown; + } default: goto unknown; @@ -8766,24 +8996,24 @@ Perl_keyword (pTHX_ const char *name, I32 len) name[5] == 'l' && name[6] == 't') { /* default */ - return (FEATURE_IS_ENABLED("switch") ? KEY_default : 0); + return (all_keywords || FEATURE_IS_ENABLED("switch") ? KEY_default : 0); } goto unknown; case 'i': if (name[4] == 'n' && - name[5] == 'e' && - name[6] == 'd') - { /* defined */ - return KEY_defined; - } + name[5] == 'e' && + name[6] == 'd') + { /* defined */ + return KEY_defined; + } - goto unknown; + goto unknown; - default: - goto unknown; - } + default: + goto unknown; + } } goto unknown; @@ -9520,9 +9750,24 @@ Perl_keyword (pTHX_ const char *name, I32 len) goto unknown; } - case 9: /* 8 tokens of length 9 */ + case 9: /* 9 tokens of length 9 */ switch (name[0]) { + case 'U': + if (name[1] == 'N' && + name[2] == 'I' && + name[3] == 'T' && + name[4] == 'C' && + name[5] == 'H' && + name[6] == 'E' && + name[7] == 'C' && + name[8] == 'K') + { /* UNITCHECK */ + return KEY_UNITCHECK; + } + + goto unknown; + case 'e': if (name[1] == 'n' && name[2] == 'd' && @@ -10199,7 +10444,7 @@ S_checkcomma(pTHX_ const char *s, const char *name, const char *what) s++; if (*s == ',') { GV* gv; - if (keyword(w, s - w)) + if (keyword(w, s - w, 0)) return; gv = gv_fetchpvn_flags(w, s - w, 0, SVt_PVCV); @@ -10229,9 +10474,10 @@ S_new_constant(pTHX_ const char *s, STRLEN len, const char *key, SV *sv, SV *pv, if (!table || !(PL_hints & HINT_LOCALIZE_HH)) { SV *msg; - why2 = strEQ(key,"charnames") - ? "(possibly a missing \"use charnames ...\")" - : ""; + why2 = (const char *) + (strEQ(key,"charnames") + ? "(possibly a missing \"use charnames ...\")" + : ""); msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s", (type ? type: "undef"), why2); @@ -10324,23 +10570,25 @@ S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_packag Perl_croak(aTHX_ ident_too_long); if (isALNUM(*s)) /* UTF handled below */ *d++ = *s++; - else if (*s == '\'' && allow_package && isIDFIRST_lazy_if(s+1,UTF)) { + else if (allow_package && (*s == '\'') && isIDFIRST_lazy_if(s+1,UTF)) { *d++ = ':'; *d++ = ':'; s++; } - else if (*s == ':' && s[1] == ':' && allow_package && s[2] != '$') { + else if (allow_package && (s[0] == ':') && (s[1] == ':') && (s[2] != '$')) { *d++ = *s++; *d++ = *s++; } else if (UTF && UTF8_IS_START(*s) && isALNUM_utf8((U8*)s)) { char *t = s + UTF8SKIP(s); + size_t len; while (UTF8_IS_CONTINUED(*t) && is_utf8_mark((U8*)t)) t += UTF8SKIP(t); - if (d + (t - s) > e) + len = t - s; + if (d + len > e) Perl_croak(aTHX_ ident_too_long); - Copy(s, d, t - s, char); - d += t - s; + Copy(s, d, len, char); + d += len; s = t; } else { @@ -10453,10 +10701,13 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL Perl_croak(aTHX_ ident_too_long); } *d = '\0'; - while (s < send && SPACE_OR_TAB(*s)) s++; + while (s < send && SPACE_OR_TAB(*s)) + s++; if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { - if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) { - const char *brack = *s == '[' ? "[...]" : "{...}"; + if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest, 0)) { + const char * const brack = + (const char *) + ((*s == '[') ? "[...]" : "{...}"); Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous use of %c{%s%s} resolved to %c%s%s", funny, dest, brack, funny, dest, brack); @@ -10485,12 +10736,13 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL PL_lex_state = LEX_INTERPEND; PL_expect = XREF; } - if (funny == '#') - funny = '@'; if (PL_lex_state == LEX_NORMAL) { if (ckWARN(WARN_AMBIGUOUS) && - (keyword(dest, d - dest) || get_cv(dest, FALSE))) + (keyword(dest, d - dest, 0) + || get_cvn_flags(dest, d - dest, 0))) { + if (funny == '#') + funny = '@'; Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Ambiguous use of %c{%s} resolved to %c%s", funny, dest, funny, dest); @@ -10533,7 +10785,8 @@ S_scan_pat(pTHX_ char *start, I32 type) dVAR; PMOP *pm; char *s = scan_str(start,!!PL_madskills,FALSE); - const char * const valid_flags = (type == OP_QR) ? "iomsx" : "iogcmsx"; + const char * const valid_flags = + (const char *)((type == OP_QR) ? "iomsx" : "iogcmsx"); #ifdef PERL_MAD char *modstart; #endif @@ -10541,9 +10794,11 @@ S_scan_pat(pTHX_ char *start, I32 type) if (!s) { const char * const delimiter = skipspace(start); - Perl_croak(aTHX_ *delimiter == '?' - ? "Search pattern not terminated or ternary operator parsed as search pattern" - : "Search pattern not terminated" ); + Perl_croak(aTHX_ + (const char *) + (*delimiter == '?' + ? "Search pattern not terminated or ternary operator parsed as search pattern" + : "Search pattern not terminated" )); } pm = (PMOP*)newPMOP(type, 0); @@ -10658,9 +10913,11 @@ S_scan_subst(pTHX_ char *start) PL_multi_end = 0; pm->op_pmflags |= PMf_EVAL; while (es-- > 0) - sv_catpv(repl, es ? "eval " : "do "); + sv_catpv(repl, (const char *)(es ? "eval " : "do ")); sv_catpvs(repl, "{"); sv_catsv(repl, PL_lex_repl); + if (strchr(SvPVX(PL_lex_repl), '#')) + sv_catpvs(repl, "\n"); sv_catpvs(repl, "}"); SvEVALED_on(repl); SvREFCNT_dec(PL_lex_repl); @@ -10741,7 +10998,7 @@ S_scan_trans(pTHX_ char *start) } no_more: - Newx(tbl, complement&&!del?258:256, short); + tbl = (short *)PerlMemShared_calloc(complement&&!del?258:256, sizeof(short)); o = newPVOP(OP_TRANS, 0, (char*)tbl); o->op_private &= ~OPpTRANS_ALL; o->op_private |= del|squash|complement| @@ -10789,7 +11046,9 @@ S_scan_heredoc(pTHX_ register char *s) e = PL_tokenbuf + sizeof PL_tokenbuf - 1; if (!outer) *d++ = '\n'; - for (peek = s; SPACE_OR_TAB(*peek); peek++) ; + peek = s; + while (SPACE_OR_TAB(*peek)) + peek++; if (*peek == '`' || *peek == '\'' || *peek =='"') { s = peek; term = *s++; @@ -10852,7 +11111,7 @@ S_scan_heredoc(pTHX_ register char *s) #ifdef PERL_MAD found_newline = 0; #endif - if ( outer || !(found_newline = memchr(s, '\n', PL_bufend - s)) ) { + if ( outer || !(found_newline = (char*)memchr((void*)s, '\n', PL_bufend - s)) ) { herewas = newSVpvn(s,PL_bufend-s); } else { @@ -10990,15 +11249,8 @@ S_scan_heredoc(pTHX_ register char *s) else if (PL_bufend - PL_linestart == 1 && PL_bufend[-1] == '\r') PL_bufend[-1] = '\n'; #endif - if (PERLDB_LINE && PL_curstash != PL_debstash) { - SV * const sv = newSV(0); - - sv_upgrade(sv, SVt_PVMG); - sv_setsv(sv,PL_linestr); - (void)SvIOK_on(sv); - SvIV_set(sv, 0); - av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop),sv); - } + if (PERLDB_LINE && PL_curstash != PL_debstash) + update_debugger_info(PL_linestr, NULL, 0); if (*s == term && memEQ(s,PL_tokenbuf,len)) { STRLEN off = PL_bufend - 1 - SvPVX_const(PL_linestr); *(SvPVX(PL_linestr) + off ) = ' '; @@ -11065,7 +11317,7 @@ S_scan_inputsymbol(pTHX_ char *start) or if it didn't end, or if we see a newline */ - if (len >= sizeof PL_tokenbuf) + if (len >= (I32)sizeof PL_tokenbuf) Perl_croak(aTHX_ "Excessively long <> operator"); if (s >= end) Perl_croak(aTHX_ "Unterminated <> operator"); @@ -11124,12 +11376,11 @@ S_scan_inputsymbol(pTHX_ char *start) filehandle */ if (*d == '$') { - I32 tmp; - /* try to find it in the pad for this block, otherwise find add symbol table ops */ - if ((tmp = pad_findmy(d)) != NOT_IN_PAD) { + const PADOFFSET tmp = pad_findmy(d); + if (tmp != NOT_IN_PAD) { if (PAD_COMPNAME_FLAGS_isOUR(tmp)) { HV * const stash = PAD_COMPNAME_OURSTASH(tmp); HEK * const stashname = HvNAME_HEK(stash); @@ -11239,7 +11490,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) { dVAR; SV *sv; /* scalar value: string */ - char *tmps; /* temp string, used for delimiter matching */ + const char *tmps; /* temp string, used for delimiter matching */ register char *s = start; /* current position in the buffer */ register char term; /* terminating character */ register char *to; /* current position in the sv's data */ @@ -11248,7 +11499,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) I32 termcode; /* terminating char. code */ U8 termstr[UTF8_MAXBYTES]; /* terminating string */ STRLEN termlen; /* length of terminating string */ - char *last = NULL; /* last position for nesting bracket */ + int last_off = 0; /* last position for nesting bracket */ #ifdef PERL_MAD int stuffstart; char *tstart; @@ -11349,9 +11600,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) else { const char *t; char *w; - if (!last) - last = SvPVX(sv); - for (t = w = last; t < svlast; w++, t++) { + for (t = w = SvPVX(sv)+last_off; t < svlast; w++, t++) { /* At here, all closes are "was quoted" one, so we don't check PL_multi_close. */ if (*t == '\\') { @@ -11370,7 +11619,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) *w = '\0'; SvCUR_set(sv, w - SvPVX_const(sv)); } - last = w; + last_off = w - SvPVX(sv); if (--brackets <= 0) cont = FALSE; } @@ -11477,7 +11726,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) */ #ifdef PERL_MAD if (PL_madskills) { - char *tstart = SvPVX(PL_linestr) + stuffstart; + char * const tstart = SvPVX(PL_linestr) + stuffstart; if (PL_thisstuff) sv_catpvn(PL_thisstuff, tstart, PL_bufend - tstart); else @@ -11497,15 +11746,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) CopLINE_inc(PL_curcop); /* update debugger info */ - if (PERLDB_LINE && PL_curstash != PL_debstash) { - SV * const line_sv = newSV(0); - - sv_upgrade(line_sv, SVt_PVMG); - sv_setsv(line_sv,PL_linestr); - (void)SvIOK_on(line_sv); - SvIV_set(line_sv, 0); - av_store(CopFILEAVx(PL_curcop), (I32)CopLINE(PL_curcop), line_sv); - } + if (PERLDB_LINE && PL_curstash != PL_debstash) + update_debugger_info(PL_linestr, NULL, 0); /* having changed the buffer, we must update PL_bufend */ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); @@ -11517,11 +11759,12 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) if (!PL_encoding || UTF) { #ifdef PERL_MAD if (PL_madskills) { - char *tstart = SvPVX(PL_linestr) + stuffstart; + char * const tstart = SvPVX(PL_linestr) + stuffstart; + const int len = s - tstart; if (PL_thisstuff) - sv_catpvn(PL_thisstuff, tstart, s - tstart); + sv_catpvn(PL_thisstuff, tstart, len); else - PL_thisstuff = newSVpvn(tstart, s - tstart); + PL_thisstuff = newSVpvn(tstart, len); if (!PL_thisclose && !keep_delims) PL_thisclose = newSVpvn(s,termlen); } @@ -11534,11 +11777,12 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) #ifdef PERL_MAD else { if (PL_madskills) { - char *tstart = SvPVX(PL_linestr) + stuffstart; + char * const tstart = SvPVX(PL_linestr) + stuffstart; + const int len = s - tstart - termlen; if (PL_thisstuff) - sv_catpvn(PL_thisstuff, tstart, s - tstart - termlen); + sv_catpvn(PL_thisstuff, tstart, len); else - PL_thisstuff = newSVpvn(tstart, s - tstart - termlen); + PL_thisstuff = newSVpvn(tstart, len); if (!PL_thisclose && !keep_delims) PL_thisclose = newSVpvn(s - termlen,termlen); } @@ -11947,7 +12191,9 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp) if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) - sv = new_constant(PL_tokenbuf, d - PL_tokenbuf, + sv = new_constant(PL_tokenbuf, + d - PL_tokenbuf, + (const char *) (floatit ? "float" : "integer"), sv, NULL, NULL); break; @@ -11991,10 +12237,13 @@ S_scan_formline(pTHX_ register char *s) while (!needargs) { if (*s == '.') { + t = s+1; #ifdef PERL_STRICT_CR - for (t = s+1;SPACE_OR_TAB(*t); t++) ; + while (SPACE_OR_TAB(*t)) + t++; #else - for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ; + while (SPACE_OR_TAB(*t) || *t == '\r') + t++; #endif if (*t == '\n' || t == PL_bufend) { eofmt = TRUE; @@ -12159,6 +12408,7 @@ Perl_yyerror(pTHX_ const char *s) const char *context = NULL; int contlen = -1; SV *msg; + int yychar = PL_parser->yychar; if (!yychar || (yychar == ';' && !PL_rsfp)) where = "at EOF"; @@ -12230,13 +12480,13 @@ Perl_yyerror(pTHX_ const char *s) PL_multi_end = 0; } if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg); + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, SVfARG(msg)); else qerror(msg); if (PL_error_count >= 10) { if (PL_in_eval && SvCUR(ERRSV)) Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n", - ERRSV, OutCopFILE(PL_curcop)); + SVfARG(ERRSV), OutCopFILE(PL_curcop)); else Perl_croak(aTHX_ "%s has too many errors.\n", OutCopFILE(PL_curcop)); @@ -12341,6 +12591,15 @@ S_swallow_bom(pTHX_ U8 *s) goto utf16be; } } +#ifdef EBCDIC + case 0xDD: + if (slen > 3 && s[1] == 0x73 && s[2] == 0x66 && s[3] == 0x73) { + if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n"); + s += 4; /* UTF-8 */ + } + break; +#endif + default: if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) { /* Leading bytes @@ -12380,7 +12639,8 @@ utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) const I32 count = FILTER_READ(idx+1, sv, maxlen); DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16_textfilter(%p): %d %d (%d)\n", - utf16_textfilter, idx, maxlen, (int) count)); + FPTR2DPTR(void *, utf16_textfilter), + idx, maxlen, (int) count)); if (count) { U8* tmps; I32 newlen; @@ -12402,7 +12662,8 @@ utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen) const I32 count = FILTER_READ(idx+1, sv, maxlen); DEBUG_P(PerlIO_printf(Perl_debug_log, "utf16rev_textfilter(%p): %d %d (%d)\n", - utf16rev_textfilter, idx, maxlen, (int) count)); + FPTR2DPTR(void *, utf16rev_textfilter), + idx, maxlen, (int) count)); if (count) { U8* tmps; I32 newlen;