X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=727fc01825a790b53f990a671835a9483af261ba;hb=e526c9e6a142067a8efdc8a9f757505ff724adb1;hp=fb301444e898e024ad70fb0bb1215680b6d93a77;hpb=b1c7b182089ae182f17e92b5d889352bce844aeb;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index fb30144..727fc01 100644 --- a/toke.c +++ b/toke.c @@ -1,6 +1,6 @@ /* toke.c * - * Copyright (c) 1991-1999, Larry Wall + * Copyright (c) 1991-2000, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -58,13 +58,6 @@ static void restore_rsfp(pTHXo_ void *f); #define LEX_FORMLINE 1 #define LEX_KNOWNEXT 0 -#ifdef I_FCNTL -#include -#endif -#ifdef I_SYS_FILE -#include -#endif - /* XXX If this causes problems, set i_unistd=undef in the hint file. */ #ifdef I_UNISTD # include /* Needed for execv() */ @@ -376,6 +369,15 @@ Perl_lex_start(pTHX_ SV *line) SAVEI32(PL_lex_state); SAVEVPTR(PL_lex_inpat); SAVEI32(PL_lex_inwhat); + if (PL_lex_state == LEX_KNOWNEXT) { + I32 toke = PL_nexttoke; + while (--toke >= 0) { + SAVEI32(PL_nexttype[toke]); + SAVEVPTR(PL_nextval[toke]); + } + SAVEI32(PL_nexttoke); + PL_nexttoke = 0; + } SAVECOPLINE(PL_curcop); SAVEPPTR(PL_bufptr); SAVEPPTR(PL_bufend); @@ -455,17 +457,22 @@ S_incline(pTHX_ char *s) dTHR; char *t; char *n; + char *e; char ch; - int sawline = 0; CopLINE_inc(PL_curcop); if (*s++ != '#') return; while (*s == ' ' || *s == '\t') s++; - if (strnEQ(s, "line ", 5)) { - s += 5; - sawline = 1; - } + if (strnEQ(s, "line", 4)) + s += 4; + else + return; + if (*s == ' ' || *s == '\t') + s++; + else + return; + while (*s == ' ' || *s == '\t') s++; if (!isDIGIT(*s)) return; n = s; @@ -473,13 +480,19 @@ S_incline(pTHX_ char *s) s++; while (*s == ' ' || *s == '\t') s++; - if (*s == '"' && (t = strchr(s+1, '"'))) + if (*s == '"' && (t = strchr(s+1, '"'))) { s++; + e = t + 1; + } else { - if (!sawline) - return; /* false alarm */ for (t = s; !isSPACE(*t); t++) ; + e = t; } + while (*e == ' ' || *e == '\t' || *e == '\r' || *e == '\f') + e++; + if (*e != '\n' && *e != '\0') + return; /* false alarm */ + ch = *t; *t = '\0'; if (t - s > 0) @@ -808,18 +821,27 @@ STATIC char * S_force_version(pTHX_ char *s) { OP *version = Nullop; + bool is_vstr = FALSE; + char *d; s = skipspace(s); - if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { - char *d = s; - if (*d == 'v') - d++; + d = s; + if (*d == 'v') { + is_vstr = TRUE; + d++; + } + if (isDIGIT(*d)) { for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++); - if ((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') { + if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) { s = scan_num(s); /* real VERSION number -- GBARR */ version = yylval.opval; + if (is_vstr) { + SV *ver = cSVOPx(version)->op_sv; + SvUPGRADE(ver, SVt_PVIV); + SvIOKp_on(ver); /* hint that it is a version */ + } } } @@ -1326,8 +1348,8 @@ S_scan_const(pTHX_ char *start) default: { dTHR; - if (ckWARN(WARN_UNSAFE) && isALPHA(*s)) - Perl_warner(aTHX_ WARN_UNSAFE, + if (ckWARN(WARN_MISC) && isALPHA(*s)) + Perl_warner(aTHX_ WARN_MISC, "Unrecognized escape \\%c passed through", *s); /* default action is to copy the quoted character */ @@ -1347,24 +1369,24 @@ S_scan_const(pTHX_ char *start) ++s; if (*s == '{') { char* e = strchr(s, '}'); + UV uv; if (!e) { yyerror("Missing right brace on \\x{}"); e = s; } - if (!utf) { - dTHR; - if (ckWARN(WARN_UTF8)) - Perl_warner(aTHX_ WARN_UTF8, - "Use of \\x{} without utf8 declaration"); - } /* note: utf always shorter than hex */ - d = (char*)uv_to_utf8((U8*)d, - (UV)scan_hex(s + 1, e - s - 1, &len)); + uv = (UV)scan_hex(s + 1, e - s - 1, &len); + if (uv > 127) { + d = (char*)uv_to_utf8((U8*)d, uv); + has_utf = TRUE; + } + else + *d++ = (char)uv; s = e + 1; - has_utf = TRUE; } else { + /* XXX collapse this branch into the one above */ UV uv = (UV)scan_hex(s, 2, &len); if (utf && PL_lex_inwhat == OP_TRANS && utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) @@ -1675,7 +1697,7 @@ S_intuit_more(pTHX_ register char *s) * Not a method if it's really "print foo $bar" * Method if it's really "foo package::" (interpreted as package->foo) * Not a method if bar is known to be a subroutne ("sub bar; foo bar") - * Not a method if bar is a filehandle or package, but is quotd with + * Not a method if bar is a filehandle or package, but is quoted with * => */ @@ -3445,7 +3467,7 @@ Perl_yylex(pTHX) OPERATOR(REFGEN); case 'v': - if (isDIGIT(s[1]) && PL_expect == XTERM) { + if (isDIGIT(s[1]) && PL_expect != XOPERATOR) { char *start = s; start++; start++; @@ -3455,6 +3477,18 @@ Perl_yylex(pTHX) s = scan_num(s); TERM(THING); } + /* avoid v123abc() or $h{v1}, allow C */ + else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF)) { + char c = *start; + GV *gv; + *start = '\0'; + gv = gv_fetchpv(s, FALSE, SVt_PVCV); + *start = c; + if (!gv) { + s = scan_num(s); + TERM(THING); + } + } } goto keylookup; case 'x': @@ -3614,8 +3648,8 @@ Perl_yylex(pTHX) if (len > 2 && PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':') { - if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV)) - Perl_warner(aTHX_ WARN_UNSAFE, + if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV)) + Perl_warner(aTHX_ WARN_BAREWORD, "Bareword \"%s\" refers to nonexistent package", PL_tokenbuf); len -= 2; @@ -3938,11 +3972,11 @@ Perl_yylex(pTHX) LOP(OP_CRYPT,XTERM); case KEY_chmod: - if (ckWARN(WARN_OCTAL)) { + if (ckWARN(WARN_CHMOD)) { for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ; if (*d != '0' && isDIGIT(*d)) - Perl_warner(aTHX_ WARN_OCTAL, - "chmod: mode argument is missing initial 0"); + Perl_warner(aTHX_ WARN_CHMOD, + "chmod() mode argument is missing initial 0"); } LOP(OP_CHMOD,XTERM); @@ -4312,8 +4346,8 @@ Perl_yylex(pTHX) char *t; for (d = s; isALNUM_lazy_if(d,UTF); d++) ; t = skipspace(d); - if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_AMBIGUOUS)) - Perl_warner(aTHX_ WARN_AMBIGUOUS, + if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE)) + Perl_warner(aTHX_ WARN_PRECEDENCE, "Precedence problem: open %.*s should be open(%.*s)", d-s,s, d-s,s); } @@ -4385,15 +4419,15 @@ Perl_yylex(pTHX) for (; isSPACE(*d) && len; --len, ++d) ; if (len) { char *b = d; - if (!warned && ckWARN(WARN_SYNTAX)) { + if (!warned && ckWARN(WARN_QW)) { for (; !isSPACE(*d) && len; --len, ++d) { if (*d == ',') { - Perl_warner(aTHX_ WARN_SYNTAX, + Perl_warner(aTHX_ WARN_QW, "Possible attempt to separate words with commas"); ++warned; } else if (*d == '#') { - Perl_warner(aTHX_ WARN_SYNTAX, + Perl_warner(aTHX_ WARN_QW, "Possible attempt to put comments in qw() list"); ++warned; } @@ -4800,10 +4834,10 @@ Perl_yylex(pTHX) LOP(OP_UTIME,XTERM); case KEY_umask: - if (ckWARN(WARN_OCTAL)) { + if (ckWARN(WARN_UMASK)) { for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ; if (*d != '0' && isDIGIT(*d)) - Perl_warner(aTHX_ WARN_OCTAL, + Perl_warner(aTHX_ WARN_UMASK, "umask: argument is missing initial 0"); } UNI(OP_UMASK); @@ -6882,43 +6916,39 @@ Perl_scan_num(pTHX_ char *start) pos++; while (isDIGIT(*pos)) pos++; - if (*pos == '.' && isDIGIT(pos[1])) { + if (!isALPHA(*pos)) { UV rev; - U8 tmpbuf[10]; + U8 tmpbuf[UTF8_MAXLEN]; U8 *tmpend; - NV nshift = 1.0; + bool utf8 = FALSE; s++; /* get past 'v' */ sv = NEWSV(92,5); - SvUPGRADE(sv, SVt_PVNV); sv_setpvn(sv, "", 0); - do { + for (;;) { + if (*s == '0' && isDIGIT(s[1])) + yyerror("Octal number in vector unsupported"); rev = atoi(s); - s = ++pos; - while (isDIGIT(*pos)) - pos++; - tmpend = uv_to_utf8(tmpbuf, rev); - *tmpend = '\0'; + utf8 = utf8 || rev > 127; sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); - if (rev > 0) - SvNVX(sv) += (NV)rev/nshift; - nshift *= 1000; - } while (*pos == '.' && isDIGIT(pos[1])); - - rev = atoi(s); - s = pos; - tmpend = uv_to_utf8(tmpbuf, rev); - *tmpend = '\0'; - sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); - if (rev > 0) - SvNVX(sv) += (NV)rev/nshift; + if (*pos == '.' && isDIGIT(pos[1])) + s = ++pos; + else { + s = pos; + break; + } + while (isDIGIT(*pos)) + pos++; + } SvPOK_on(sv); - SvNOK_on(sv); SvREADONLY_on(sv); - SvUTF8_on(sv); + if (utf8) { + SvUTF8_on(sv); + sv_utf8_downgrade(sv, TRUE); + } } } break; @@ -7039,8 +7069,7 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) SAVEI32(PL_subline); save_item(PL_subname); SAVEI32(PL_padix); - SAVEVPTR(PL_curpad); - SAVESPTR(PL_comppad); + SAVECOMPPAD(); SAVESPTR(PL_comppad_name); SAVESPTR(PL_compcv); SAVEI32(PL_comppad_name_fill); @@ -7119,7 +7148,12 @@ Perl_yyerror(pTHX_ char *s) } else if (yychar > 255) where = "next token ???"; +#ifdef USE_PURE_BISON +/* GNU Bison sets the value -2 */ + else if (yychar == -2) { +#else else if ((yychar & 127) == 127) { +#endif if (PL_lex_state == LEX_NORMAL || (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL)) where = "at end of line";