X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=ae4558bee2dde3c19912cf55e6c63a6926ffd3ab;hb=e40b81a3dd247b1a29fc78399677b77b78b5f183;hp=30a4548c9239f37f633ae3f62a37efcbfaf75ece;hpb=94def1405ef0309d21046501deec4cd7d2323919;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index 30a4548..ae4558b 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"; @@ -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; @@ -776,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, @@ -1275,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) @@ -1541,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; @@ -1674,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; } @@ -1787,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+*?|()-nrtfeaxcz0123456789[{]} \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); @@ -1810,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) @@ -1823,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_ @@ -1853,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; @@ -1869,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; @@ -1881,6 +1996,7 @@ S_scan_const(pTHX_ char *start) didrange = FALSE; #ifdef EBCDIC literal_endpoint = 0; + native_range = TRUE; #endif } } @@ -1927,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. @@ -1947,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])) @@ -1969,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) { @@ -1985,8 +2104,8 @@ S_scan_const(pTHX_ char *start) 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; } @@ -2084,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; @@ -2102,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{}"); @@ -2115,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); @@ -2161,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); @@ -2234,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++); @@ -2268,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); @@ -2389,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; @@ -2421,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) @@ -2500,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'; @@ -2755,6 +2894,34 @@ S_find_in_my_stash(pTHX_ const char *pkgname, I32 len) 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 @@ -2793,7 +2960,7 @@ 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 * const tstart = SvPVX(PL_linestr) + PL_realtokenstart; PL_thistoken = newSVpvn(tstart, s - tstart); @@ -3011,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", @@ -3092,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(')'); @@ -3101,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; } @@ -3119,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; @@ -3158,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); } @@ -3172,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)) */ @@ -3218,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)) */ @@ -3244,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(')'); @@ -3295,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)) */ @@ -3348,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"); @@ -3417,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 { @@ -3450,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; @@ -3504,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); @@ -3515,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) { @@ -3795,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; @@ -3971,8 +4134,7 @@ Perl_yylex(pTHX) /* FALL THROUGH */ case '~': if (s[1] == '~' - && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR) - && FEATURE_IS_ENABLED("~~")) + && (PL_expect == XOPERATOR || PL_expect == XTERMORDORDOR)) { s += 2; Eop(OP_SMARTMATCH); @@ -4013,7 +4175,7 @@ Perl_yylex(pTHX) 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: @@ -4122,10 +4284,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(':'); @@ -4362,7 +4525,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 @@ -4387,7 +4550,7 @@ Perl_yylex(pTHX) force_next('}'); #ifdef PERL_MAD if (!PL_thistoken) - PL_thistoken = newSVpvn("",0); + PL_thistoken = newSVpvs(""); #endif TOKEN(';'); case '&': @@ -4461,7 +4624,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); } @@ -4631,12 +4794,12 @@ Perl_yylex(pTHX) t++; } while (isSPACE(*t)); if (isIDFIRST_lazy_if(t,UTF)) { - STRLEN dummylen; + STRLEN len; t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, - &dummylen); + &len); while (isSPACE(*t)) t++; - if (*t == ';' && get_cv(tmpbuf, FALSE)) + if (*t == ';' && get_cvn_flags(tmpbuf, len, 0)) Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "You need to quote \"%s\"", tmpbuf); @@ -4658,7 +4821,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: @@ -4855,8 +5018,7 @@ Perl_yylex(pTHX) no_op("Backticks",s); if (!s) missingterm(NULL); - yylval.ival = OP_BACKTICK; - set_csh(); + readpipe_override(); TERM(sublex_start()); case '\\': @@ -4931,9 +5093,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); @@ -4956,13 +5119,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] == '>') { @@ -5242,7 +5405,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); @@ -5300,18 +5463,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); } } @@ -5327,7 +5493,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); @@ -5344,7 +5510,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)) @@ -5367,7 +5533,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); } @@ -5501,7 +5667,7 @@ Perl_yylex(pTHX) PUTBACK; PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, Perl_form(aTHX_ ":encoding(%"SVf")", - (void*)name)); + SVfARG(name))); FREETMPS; LEAVE; } @@ -5512,7 +5678,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); @@ -5530,6 +5696,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: @@ -5544,7 +5711,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; @@ -6170,8 +6337,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: @@ -6388,7 +6554,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 @@ -6468,6 +6634,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) @@ -6475,19 +6643,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", - (void*)PL_subname, d); + SVfARG(PL_subname), d); SvCUR_set(PL_lex_stuff, tmp); have_proto = TRUE; @@ -6516,14 +6683,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, (void*)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); @@ -6539,7 +6706,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 @@ -6845,7 +7013,7 @@ 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; switch (len) @@ -7117,7 +7285,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; @@ -7256,7 +7424,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; @@ -7780,7 +7948,7 @@ Perl_keyword (pTHX_ const char *name, I32 len) 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; @@ -7863,7 +8031,7 @@ Perl_keyword (pTHX_ const char *name, I32 len) 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; @@ -7991,7 +8159,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; @@ -8159,7 +8327,7 @@ Perl_keyword (pTHX_ const char *name, I32 len) if (name[3] == 't' && name[4] == 'e') { /* state */ - return (FEATURE_IS_ENABLED("state") ? KEY_state : 0); + return (all_keywords || FEATURE_IS_ENABLED("state") ? KEY_state : 0); } goto unknown; @@ -8827,7 +8995,7 @@ 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; @@ -9581,9 +9749,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' && @@ -10260,7 +10443,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); @@ -10290,9 +10473,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); @@ -10519,8 +10703,10 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL while (s < send && SPACE_OR_TAB(*s)) s++; if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { - if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) { - const char * const 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); @@ -10551,7 +10737,8 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL } 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 = '@'; @@ -10575,20 +10762,16 @@ void Perl_pmflag(pTHX_ U32* pmfl, int ch) { PERL_UNUSED_CONTEXT; - if (ch == 'i') - *pmfl |= PMf_FOLD; - else if (ch == 'g') - *pmfl |= PMf_GLOBAL; - else if (ch == 'c') - *pmfl |= PMf_CONTINUE; - else if (ch == 'o') - *pmfl |= PMf_KEEP; - else if (ch == 'm') - *pmfl |= PMf_MULTILINE; - else if (ch == 's') - *pmfl |= PMf_SINGLELINE; - else if (ch == 'x') - *pmfl |= PMf_EXTENDED; + if (ch<256) { + char c = (char)ch; + switch (c) { + CASE_STD_PMMOD_FLAGS_PARSE_SET(pmfl); + case GLOBAL_PAT_MOD: *pmfl |= PMf_GLOBAL; break; + case CONTINUE_PAT_MOD: *pmfl |= PMf_CONTINUE; break; + case ONCE_PAT_MOD: *pmfl |= PMf_KEEP; break; + case KEEPCOPY_PAT_MOD: *pmfl |= PMf_KEEPCOPY; break; + } + } } STATIC char * @@ -10597,7 +10780,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) ? QR_PAT_MODS : M_PAT_MODS); #ifdef PERL_MAD char *modstart; #endif @@ -10605,9 +10789,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); @@ -10628,7 +10814,8 @@ S_scan_pat(pTHX_ char *start, I32 type) if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL) && ckWARN(WARN_REGEXP)) { - Perl_warner(aTHX_ packWARN(WARN_REGEXP), "Use of /c modifier is meaningless without /g" ); + Perl_warner(aTHX_ packWARN(WARN_REGEXP), + "Use of /c modifier is meaningless without /g" ); } pm->op_pmpermflags = pm->op_pmflags; @@ -10692,11 +10879,11 @@ S_scan_subst(pTHX_ char *start) #endif while (*s) { - if (*s == 'e') { + if (*s == EXEC_PAT_MOD) { s++; es++; } - else if (strchr("iogcmsx", *s)) + else if (strchr(S_PAT_MODS, *s)) pmflag(&pm->op_pmflags,*s++); else break; @@ -10722,7 +10909,7 @@ 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), '#')) @@ -10807,7 +10994,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| @@ -10920,7 +11107,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 { @@ -11058,15 +11245,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 ) = ' '; @@ -11306,7 +11486,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 */ @@ -11315,7 +11495,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; @@ -11416,9 +11596,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 == '\\') { @@ -11437,7 +11615,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; } @@ -11564,15 +11742,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); @@ -11585,7 +11756,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) #ifdef PERL_MAD if (PL_madskills) { char * const tstart = SvPVX(PL_linestr) + stuffstart; - const int len = s - start; + const int len = s - tstart; if (PL_thisstuff) sv_catpvn(PL_thisstuff, tstart, len); else @@ -12016,7 +12187,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; @@ -12231,6 +12404,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"; @@ -12302,13 +12476,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, (void*)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", - (void*)ERRSV, OutCopFILE(PL_curcop)); + SVfARG(ERRSV), OutCopFILE(PL_curcop)); else Perl_croak(aTHX_ "%s has too many errors.\n", OutCopFILE(PL_curcop)); @@ -12413,6 +12587,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