X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=d61063a12cf1a4ebe96f5227b3c3e8b90fcd6127;hb=7d4724f95a69a8d5a7cd565f21487912e6d331c0;hp=30a4548c9239f37f633ae3f62a37efcbfaf75ece;hpb=94def1405ef0309d21046501deec4cd7d2323919;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index 30a4548..d61063a 100644 --- a/toke.c +++ b/toke.c @@ -662,13 +662,11 @@ Perl_lex_start(pTHX_ SV *line) 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;"); + if (SvREADONLY(PL_linestr) || !len || s[len-1] != ';') { + PL_linestr = sv_2mortal(len ? newSVsv(PL_linestr) : newSVpvn(s, 0)); + if (!len || s[len-1] != ';') + sv_catpvs(PL_linestr, "\n;"); } SvTEMP_off(PL_linestr); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr); @@ -776,12 +774,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 ${"::_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 +1681,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 +1794,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 +1813,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 +1834,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 +1895,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 +1933,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 +1949,7 @@ S_scan_const(pTHX_ char *start) didrange = FALSE; #ifdef EBCDIC literal_endpoint = 0; + native_range = TRUE; #endif } } @@ -1927,9 +1996,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 +2021,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 +2036,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 +2057,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 +2156,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 +2178,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 +2192,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 +2243,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 +2320,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 +2358,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 +2481,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 +2513,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 +2592,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 +2847,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 +2913,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 +3131,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 +3219,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 +3228,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 +3246,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 +3285,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 +3299,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 +3345,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 +3371,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 +3422,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 +3475,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"); @@ -3450,8 +3578,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; @@ -3795,7 +3925,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; @@ -4013,7 +4143,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 +4252,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 +4493,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 +4518,7 @@ Perl_yylex(pTHX) force_next('}'); #ifdef PERL_MAD if (!PL_thistoken) - PL_thistoken = newSVpvn("",0); + PL_thistoken = newSVpvs(""); #endif TOKEN(';'); case '&': @@ -4461,7 +4592,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); } @@ -4658,7 +4789,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 +4986,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 +5061,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); @@ -4962,7 +5093,7 @@ Perl_yylex(pTHX) } /* 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 +5373,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 +5431,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 +5461,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 +5478,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 +5501,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); } @@ -5512,7 +5646,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 +5664,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 +5679,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 +6305,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 +6522,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 +6602,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,16 +6611,15 @@ 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); @@ -6523,7 +6658,7 @@ Perl_yylex(pTHX) start_force(0); if (tmpwhite) { if (PL_madskills) - curmad('^', newSVpvn("",0)); + curmad('^', newSVpvs("")); CURMAD('_', tmpwhite); } force_next(0); @@ -6539,7 +6674,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 +6981,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 +7253,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 +7392,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 +7916,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 +7999,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 +8127,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 +8295,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 +8963,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 +9717,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 +10411,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 +10441,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 +10671,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 +10705,7 @@ 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_cv(dest, FALSE))) { if (funny == '#') funny = '@'; @@ -10597,7 +10751,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 @@ -10605,9 +10760,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); @@ -10722,7 +10879,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), '#')) @@ -10920,7 +11077,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 { @@ -11306,7 +11463,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 +11472,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 +11573,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 +11592,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; } @@ -12016,7 +12171,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; @@ -12413,6 +12570,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