X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9508c957d44b9a653d85a843d414d761b7658938..01a19ab0a2917aedc73dc22d27746912f8baa335:/toke.c diff --git a/toke.c b/toke.c index d798946..1aceaec 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, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 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. @@ -715,15 +715,17 @@ S_skipspace(pTHX_ register char *s) (prevlen = SvCUR(PL_linestr)))) == Nullch) { /* end of file. Add on the -p or -n magic */ - if (PL_minus_n || PL_minus_p) { - sv_setpv(PL_linestr,PL_minus_p ? - ";}continue{print or die qq(-p destination: $!\\n)" : - ""); - sv_catpv(PL_linestr,";}"); + if (PL_minus_p) { + sv_setpv(PL_linestr, + ";}continue{print or die qq(-p destination: $!\\n);}"); PL_minus_n = PL_minus_p = 0; } + else if (PL_minus_n) { + sv_setpvn(PL_linestr, ";}", 2); + PL_minus_n = 0; + } else - sv_setpv(PL_linestr,";"); + sv_setpvn(PL_linestr,";", 1); /* reset variables for next time we lex */ PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = s = PL_linestart @@ -1966,8 +1968,10 @@ S_intuit_more(pTHX_ register char *s) weight -= 5; /* cope with negative subscript */ break; default: - if (!isALNUM(last_un_char) && !strchr("$@&",last_un_char) && - isALPHA(*s) && s[1] && isALPHA(s[1])) { + if (!isALNUM(last_un_char) + && !(last_un_char == '$' || last_un_char == '@' + || last_un_char == '&') + && isALPHA(*s) && s[1] && isALPHA(s[1])) { char *d = tmpbuf; while (isALPHA(*s)) *d++ = *s++; @@ -2358,7 +2362,8 @@ Perl_yylex(pTHX) oldmod = PL_lex_casestack[--PL_lex_casemods]; PL_lex_casestack[PL_lex_casemods] = '\0'; - if (PL_bufptr != PL_bufend && strchr("LUQ", oldmod)) { + if (PL_bufptr != PL_bufend + && (oldmod == 'L' || oldmod == 'U' || oldmod == 'Q')) { PL_bufptr += 2; PL_lex_state = LEX_INTERPCONCAT; } @@ -2381,7 +2386,7 @@ Perl_yylex(pTHX) else { if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3)) tmp = *s, *s = s[2], s[2] = (char)tmp; /* misordered... */ - if (strchr("LU", *s) && + if ((*s == 'L' || *s == 'U') && (strchr(PL_lex_casestack, 'L') || strchr(PL_lex_casestack, 'U'))) { PL_lex_casestack[--PL_lex_casemods] = '\0'; return REPORT(')'); @@ -2565,12 +2570,12 @@ Perl_yylex(pTHX) PL_preambled = TRUE; sv_setpv(PL_linestr,incl_perldb()); if (SvCUR(PL_linestr)) - sv_catpv(PL_linestr,";"); + sv_catpvn(PL_linestr,";", 1); if (PL_preambleav){ while(AvFILLp(PL_preambleav) >= 0) { SV *tmpsv = av_shift(PL_preambleav); sv_catsv(PL_linestr, tmpsv); - sv_catpv(PL_linestr, ";"); + sv_catpvn(PL_linestr, ";", 1); sv_free(tmpsv); } sv_free((SV*)PL_preambleav); @@ -2582,29 +2587,23 @@ Perl_yylex(pTHX) sv_catpv(PL_linestr,"chomp;"); if (PL_minus_a) { if (PL_minus_F) { - if (strchr("/'\"", *PL_splitstr) + if ((*PL_splitstr == '/' || *PL_splitstr == '\'' + || *PL_splitstr == '"') && strchr(PL_splitstr + 1, *PL_splitstr)) Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr); else { - char delim; - s = "'~#\200\1'"; /* surely one char is unused...*/ - while (s[1] && strchr(PL_splitstr, *s)) s++; - delim = *s; - Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c", - "q" + (delim == '\''), delim); - for (s = PL_splitstr; *s; s++) { - if (*s == '\\') - sv_catpvn(PL_linestr, "\\", 1); - sv_catpvn(PL_linestr, s, 1); - } - Perl_sv_catpvf(aTHX_ PL_linestr, "%c);", delim); + /* "q\0${splitstr}\0" is legal perl. Yes, even NUL + bytes can be used as quoting characters. :-) */ + Perl_sv_catpvf(aTHX_ PL_linestr, + "our @F=split(q%c%s%c);", + 0, PL_splitstr, 0); } } else sv_catpv(PL_linestr,"our @F=split(' ');"); } } - sv_catpv(PL_linestr, "\n"); + sv_catpvn(PL_linestr, "\n", 1); PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = Nullch; @@ -2634,8 +2633,8 @@ Perl_yylex(pTHX) PL_doextract = FALSE; } if (!PL_in_eval && (PL_minus_n || PL_minus_p)) { - sv_setpv(PL_linestr,PL_minus_p ? ";}continue{print" : ""); - sv_catpv(PL_linestr,";}"); + sv_setpv(PL_linestr,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 = Nullch; @@ -3714,7 +3713,8 @@ Perl_yylex(pTHX) PL_expect = XTERM; /* e.g. print $fh 3 */ else if (*s == '.' && isDIGIT(s[1])) PL_expect = XTERM; /* e.g. print $fh .3 */ - else if (strchr("?-+", *s) && !isSPACE(s[1]) && s[1] != '=') + else if ((*s == '?' || *s == '-' || *s == '+') + && !isSPACE(s[1]) && s[1] != '=') PL_expect = XTERM; /* e.g. print $fh -1 */ else if (*s == '/' && !isSPACE(s[1]) && s[1] != '=' && s[1] != '/') PL_expect = XTERM; /* e.g. print $fh /.../ @@ -4248,7 +4248,7 @@ Perl_yylex(pTHX) char *proto = SvPV((SV*)cv, len); if (!len) TERM(FUNC0SUB); - if (strEQ(proto, "$")) + if (*proto == '$' && proto[1] == '\0') OPERATOR(UNIOPSUB); while (*proto == ';') proto++; @@ -4281,7 +4281,8 @@ Perl_yylex(pTHX) } safe_bareword: - if (lastchar && strchr("*%&", lastchar) && ckWARN_d(WARN_AMBIGUOUS)) { + if ((lastchar == '*' || lastchar == '%' || lastchar == '&') + && ckWARN_d(WARN_AMBIGUOUS)) { Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), "Operator or semicolon missing before %c%s", lastchar, PL_tokenbuf); @@ -5782,7 +5783,7 @@ Perl_keyword(pTHX_ register char *d, I32 len) else if (*d == 'l') { if (strEQ(d,"login")) return -KEY_getlogin; } - else if (strEQ(d,"c")) return -KEY_getc; + else if (*d == 'c' && d[1] == '\0') return -KEY_getc; break; } switch (len) { @@ -5929,12 +5930,16 @@ Perl_keyword(pTHX_ register char *d, I32 len) } break; case 'q': - if (len <= 2) { - if (strEQ(d,"q")) return KEY_q; - if (strEQ(d,"qr")) return KEY_qr; - if (strEQ(d,"qq")) return KEY_qq; - if (strEQ(d,"qw")) return KEY_qw; - if (strEQ(d,"qx")) return KEY_qx; + if (len == 1) { + return KEY_q; + } + else if (len == 2) { + switch (d[1]) { + case 'r': return KEY_qr; + case 'q': return KEY_qq; + case 'w': return KEY_qw; + case 'x': return KEY_qx; + }; } else if (strEQ(d,"quotemeta")) return -KEY_quotemeta; break; @@ -6406,7 +6411,7 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des return s; } if (*s == '$' && s[1] && - (isALNUM_lazy_if(s+1,UTF) || strchr("${", s[1]) || strnEQ(s+1,"::",2)) ) + (isALNUM_lazy_if(s+1,UTF) || s[1] == '$' || s[1] == '{' || strnEQ(s+1,"::",2)) ) { return s; } @@ -6659,15 +6664,23 @@ S_scan_trans(pTHX_ char *start) } complement = del = squash = 0; - while (strchr("cds", *s)) { - if (*s == 'c') + while (1) { + switch (*s) { + case 'c': complement = OPpTRANS_COMPLEMENT; - else if (*s == 'd') + break; + case 'd': del = OPpTRANS_DELETE; - else if (*s == 's') + break; + case 's': squash = OPpTRANS_SQUASH; + break; + default: + goto no_more; + } s++; } + no_more: New(803, tbl, complement&&!del?258:256, short); o = newPVOP(OP_TRANS, 0, (char*)tbl); @@ -6700,7 +6713,7 @@ S_scan_heredoc(pTHX_ register char *s) if (!outer) *d++ = '\n'; for (peek = s; SPACE_OR_TAB(*peek); peek++) ; - if (*peek && strchr("`'\"",*peek)) { + if (*peek == '`' || *peek == '\'' || *peek =='"') { s = peek; term = *s++; s = delimcpy(d, e, s, PL_bufend, term, &len); @@ -7659,7 +7672,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) } /* read exponent part, if present */ - if (*s && strchr("eE",*s) && strchr("+-0123456789_", s[1])) { + if ((*s == 'e' || *s == 'E') && strchr("+-0123456789_", s[1])) { floatit = TRUE; s++;