X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=d61063a12cf1a4ebe96f5227b3c3e8b90fcd6127;hb=4a4e7719d3ad3a7cd7b1504c2ab39dd9db11de1f;hp=927f904cb6cf79b8b6efcfc0abb6dd707b9b38e6;hpb=6b29d1f5fb68d0a6bdb42e4e05f5a784ded55e44;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index 927f904..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; @@ -1790,12 +1797,6 @@ S_scan_const(pTHX_ char *start) bool native_range = TRUE; /* turned to FALSE if the first endpoint is Unicode. */ #endif - const char * const leaveit = /* set of acceptably-backslashed characters */ - (const char *) - (PL_lex_inpat - ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-Nnrktfeaxcz0123456789[{]} \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); @@ -2020,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])) @@ -2042,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) { @@ -2848,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 @@ -4959,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 '\\': @@ -5405,12 +5431,13 @@ 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++; @@ -5637,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: @@ -6277,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: @@ -6574,6 +6601,9 @@ 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) @@ -6581,23 +6611,18 @@ Perl_yylex(pTHX) /* strip spaces and check for bad characters */ d = SvPVX(PL_lex_stuff); tmp = 0; - { - char *p; - bool bad_proto = FALSE; - const bool warnsyntax = ckWARN(WARN_SYNTAX); - for (p = d; *p; ++p) { - if (!isSPACE(*p)) { - d[tmp++] = *p; - if (warnsyntax && !strchr("$@%*;[]&\\", *p)) - bad_proto = TRUE; - } + for (p = d; *p; ++p) { + if (!isSPACE(*p)) { + d[tmp++] = *p; + if (warnsyntax && !strchr("$@%*;[]&\\_", *p)) + bad_proto = TRUE; } - d[tmp] = '\0'; - if (bad_proto) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Illegal character in prototype for %"SVf" : %s", - (void*)PL_subname, d); } + d[tmp] = '\0'; + if (bad_proto) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "Illegal character in prototype for %"SVf" : %s", + (void*)PL_subname, d); SvCUR_set(PL_lex_stuff, tmp); have_proto = TRUE; @@ -7367,7 +7392,7 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords) case 'a': if (name[2] == 'y') { /* say */ - return (all_keywords || FEATURE_IS_ENABLED("say") ? -KEY_say : 0); + return (all_keywords || FEATURE_IS_ENABLED("say") ? KEY_say : 0); } goto unknown; @@ -9692,9 +9717,24 @@ Perl_keyword (pTHX_ const char *name, I32 len, bool all_keywords) 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' && @@ -11432,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; @@ -11533,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 == '\\') { @@ -11554,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; }