X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=cd6ed1d32cde2b8095cbcea0c59bca467a6e8335;hb=98a29390254d3cb423096b6282689bfe2a7e6a13;hp=78ed359890c2464260e899501da285c147924054;hpb=fcc8fcf67e5ea5f08178c9ac86509bc972ef38ff;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index 78ed359..cd6ed1d 100644 --- a/toke.c +++ b/toke.c @@ -13,7 +13,7 @@ /* * This file is the lexer for Perl. It's closely linked to the - * parser, perly.y. + * parser, perly.y. * * The main routine is yylex(), which returns the next token. */ @@ -39,7 +39,7 @@ static I32 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen); /*#define UTF (SvUTF8(PL_linestr) && !(PL_hints & HINT_BYTE))*/ #define UTF (PL_hints & HINT_UTF8) -/* In variables name $^X, these are the legal values for X. +/* In variables name $^X, these are the legal values for X. * 1999-02-27 mjd-perl-patch@plover.com */ #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x))) @@ -69,20 +69,14 @@ static I32 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen); #define LEX_FORMLINE 1 #define LEX_KNOWNEXT 0 -/* XXX If this causes problems, set i_unistd=undef in the hint file. */ -#ifdef I_UNISTD -# include /* Needed for execv() */ -#endif - - #ifdef ff_next #undef ff_next #endif #ifdef USE_PURE_BISON -#ifndef YYMAXLEVEL -#define YYMAXLEVEL 100 -#endif +# ifndef YYMAXLEVEL +# define YYMAXLEVEL 100 +# endif YYSTYPE* yylval_pointer[YYMAXLEVEL]; int* yychar_pointer[YYMAXLEVEL]; int yyactlevel = 0; @@ -91,8 +85,8 @@ int yyactlevel = 0; # define yylval (*yylval_pointer[yyactlevel]) # define yychar (*yychar_pointer[yyactlevel]) # define PERL_YYLEX_PARAM yylval_pointer[yyactlevel],yychar_pointer[yyactlevel] -# undef yylex -# define yylex() Perl_yylex(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]) +# undef yylex +# define yylex() Perl_yylex_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]) #endif #include "keywords.h" @@ -127,7 +121,7 @@ int yyactlevel = 0; * Aop : addition-level operator * Mop : multiplication-level operator * Eop : equality-testing operator - * Rop : relational operator <= != gt + * Rop : relational operator <= != gt * * Also see LOP and lop() below. */ @@ -280,7 +274,6 @@ S_missingterm(pTHX_ char *s) void Perl_deprecate(pTHX_ char *s) { - dTHR; if (ckWARN(WARN_DEPRECATED)) Perl_warner(aTHX_ WARN_DEPRECATED, "Use of %s is deprecated", s); } @@ -343,7 +336,6 @@ S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) void Perl_lex_start(pTHX_ SV *line) { - dTHR; char *s; STRLEN len; @@ -439,7 +431,6 @@ Perl_lex_end(pTHX) STATIC void S_incline(pTHX_ char *s) { - dTHR; char *t; char *n; char *e; @@ -455,7 +446,7 @@ S_incline(pTHX_ char *s) return; if (*s == ' ' || *s == '\t') s++; - else + else return; while (SPACE_OR_TAB(*s)) s++; if (!isDIGIT(*s)) @@ -501,7 +492,6 @@ S_incline(pTHX_ char *s) STATIC char * S_skipspace(pTHX_ register char *s) { - dTHR; if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { while (s < PL_bufend && SPACE_OR_TAB(*s)) s++; @@ -620,7 +610,6 @@ S_check_uni(pTHX) { char *s; char *t; - dTHR; if (PL_oldoldbufptr != PL_last_uni) return; @@ -632,8 +621,8 @@ S_check_uni(pTHX) if (ckWARN_d(WARN_AMBIGUOUS)){ char ch = *s; *s = '\0'; - Perl_warner(aTHX_ WARN_AMBIGUOUS, - "Warning: Use of \"%s\" without parens is ambiguous", + Perl_warner(aTHX_ WARN_AMBIGUOUS, + "Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni); *s = ch; } @@ -686,7 +675,6 @@ S_uni(pTHX_ I32 f, char *s) STATIC I32 S_lop(pTHX_ I32 f, int x, char *s) { - dTHR; yylval.ival = f; CLINE; PL_expect = x; @@ -713,7 +701,7 @@ S_lop(pTHX_ I32 f, int x, char *s) * handles the token correctly. */ -STATIC void +STATIC void S_force_next(pTHX_ I32 type) { PL_nexttype[PL_nexttoke] = type; @@ -746,7 +734,7 @@ S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow { register char *s; STRLEN len; - + start = skipspace(start); s = start; if (isIDFIRST_lazy_if(s,UTF) || @@ -788,7 +776,6 @@ S_force_ident(pTHX_ register char *s, int kind) PL_nextval[PL_nexttoke].opval = o; force_next(WORD); if (kind) { - dTHR; /* just for in_eval */ o->op_private = OPpCONST_ENTERED; /* XXX see note in pp_entereval() for why we forgo typo warnings if the symbol must be introduced in an eval. @@ -816,7 +803,7 @@ Perl_str_to_version(pTHX_ SV *sv) STRLEN skip; UV n; if (utf) - n = utf8_to_uv_chk((U8*)start, len, &skip, 0); + n = utf8_to_uv((U8*)start, len, &skip, 0); else { n = *(U8*)start; skip = 1; @@ -828,7 +815,7 @@ Perl_str_to_version(pTHX_ SV *sv) return retval; } -/* +/* * S_force_version * Forces the next token to be a version number. */ @@ -861,7 +848,7 @@ S_force_version(pTHX_ char *s) /* NOTE: The parser sees the package name and the VERSION swapped */ PL_nextval[PL_nexttoke].opval = version; - force_next(WORD); + force_next(WORD); return (s); } @@ -969,7 +956,7 @@ S_sublex_start(pTHX) SvUTF8_on(nsv); SvREFCNT_dec(sv); sv = nsv; - } + } yylval.opval = (OP*)newSVOP(op_type, 0, sv); PL_lex_stuff = Nullsv; return THING; @@ -1001,7 +988,6 @@ S_sublex_start(pTHX) STATIC I32 S_sublex_push(pTHX) { - dTHR; ENTER; PL_lex_state = PL_sublex_info.super_state; @@ -1175,7 +1161,7 @@ S_sublex_done(pTHX) } (end switch) } (end if backslash) } (end while character to read) - + */ STATIC char * @@ -1187,13 +1173,13 @@ S_scan_const(pTHX_ char *start) register char *d = SvPVX(sv); /* destination for copies */ bool dorange = FALSE; /* are we in a translit range? */ bool didrange = FALSE; /* did we just finish a range? */ - bool has_utf = FALSE; /* embedded \x{} */ + bool has_utf8 = FALSE; /* embedded \x{} */ UV uv; I32 utf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) ? (PL_sublex_info.sub_op->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) : UTF; - I32 thisutf = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) + I32 this_utf8 = (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) ? (PL_sublex_info.sub_op->op_private & (PL_lex_repl ? OPpTRANS_FROM_UTF : OPpTRANS_TO_UTF)) : UTF; @@ -1247,11 +1233,11 @@ S_scan_const(pTHX_ char *start) dorange = FALSE; didrange = TRUE; continue; - } + } /* range begins (ignore - as first or last char) */ else if (*s == '-' && s+1 < send && s != start) { - if (didrange) { + if (didrange) { Perl_croak(aTHX_ "Ambiguous range in transliteration operator"); } if (utf) { @@ -1286,9 +1272,9 @@ S_scan_const(pTHX_ char *start) while (count && (c = *regparse)) { if (c == '\\' && regparse[1]) regparse++; - else if (c == '{') + else if (c == '{') count++; - else if (c == '}') + else if (c == '}') count--; regparse++; } @@ -1327,12 +1313,13 @@ S_scan_const(pTHX_ char *start) /* (now in tr/// code again) */ - if (*s & 0x80 && thisutf) { - STRLEN len; + if (*s & 0x80 && (this_utf8 || has_utf8)) { + STRLEN len = (STRLEN) -1; UV uv; - - uv = utf8_to_uv_chk((U8*)s, send - s, &len, UTF8_CHECK_ONLY); - if (len == 1) { + if (this_utf8) { + uv = utf8_to_uv((U8*)s, send - s, &len, UTF8_CHECK_ONLY); + } + if (len == (STRLEN)-1) { /* Illegal UTF8 (a high-bit byte), make it valid. */ char *old_pvx = SvPVX(sv); /* need space for one extra char (NOTE: SvCUR() not set here) */ @@ -1343,7 +1330,7 @@ S_scan_const(pTHX_ char *start) while (len--) *d++ = *s++; } - has_utf = TRUE; + has_utf8 = TRUE; continue; } @@ -1362,7 +1349,6 @@ S_scan_const(pTHX_ char *start) if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat && isDIGIT(*s) && *s != '0' && !isDIGIT(s[1])) { - dTHR; /* only for ckWARN */ if (ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ WARN_SYNTAX, "\\%c better written as $%c", *s, *s); *--s = '$'; @@ -1387,9 +1373,8 @@ S_scan_const(pTHX_ char *start) /* FALL THROUGH */ default: { - dTHR; if (ckWARN(WARN_MISC) && isALNUM(*s)) - Perl_warner(aTHX_ WARN_MISC, + Perl_warner(aTHX_ WARN_MISC, "Unrecognized escape \\%c passed through", *s); /* default action is to copy the quoted character */ @@ -1416,9 +1401,10 @@ S_scan_const(pTHX_ char *start) yyerror("Missing right brace on \\x{}"); e = s; } - { + else { STRLEN len = 1; /* allow underscores */ uv = (UV)scan_hex(s + 1, e - s - 1, &len); + has_utf8 = TRUE; } s = e + 1; } @@ -1435,8 +1421,8 @@ S_scan_const(pTHX_ char *start) * There will always enough room in sv since such escapes will * be longer than any utf8 sequence they can end up as */ - if (uv > 127) { - if (!thisutf && !has_utf && uv > 255) { + if (uv > 127 || has_utf8) { + if (!this_utf8 && !has_utf8 && uv > 255) { /* might need to recode whatever we have accumulated so far * if it contains any hibit chars */ @@ -1468,9 +1454,9 @@ S_scan_const(pTHX_ char *start) } } - if (thisutf || uv > 255) { + if (has_utf8 || uv > 255) { d = (char*)uv_to_utf8((U8*)d, uv); - has_utf = TRUE; + has_utf8 = TRUE; } else { *d++ = (char)uv; @@ -1489,17 +1475,17 @@ S_scan_const(pTHX_ char *start) SV *res; STRLEN len; char *str; - + if (!e) { yyerror("Missing right brace on \\N{}"); e = s - 1; goto cont_scan; } res = newSVpvn(s + 1, e - s - 1); - res = new_constant( Nullch, 0, "charnames", + res = new_constant( Nullch, 0, "charnames", res, Nullsv, "\\N{...}" ); str = SvPV(res,len); - if (!has_utf && SvUTF8(res)) { + if (!has_utf8 && SvUTF8(res)) { char *ostart = SvPVX(sv); SvCUR_set(sv, d - ostart); SvPOK_on(sv); @@ -1508,7 +1494,7 @@ S_scan_const(pTHX_ char *start) /* this just broke our allocation above... */ SvGROW(sv, send - start); d = SvPVX(sv) + SvCUR(sv); - has_utf = TRUE; + has_utf8 = TRUE; } if (len > e - s + 4) { char *odest = SvPVX(sv); @@ -1533,7 +1519,7 @@ S_scan_const(pTHX_ char *start) *d = *s++; if (isLOWER(*d)) *d = toUPPER(*d); - *d = toCTRL(*d); + *d = toCTRL(*d); d++; #else { @@ -1587,7 +1573,7 @@ S_scan_const(pTHX_ char *start) *d = '\0'; SvCUR_set(sv, d - SvPVX(sv)); SvPOK_on(sv); - if (has_utf) + if (has_utf8) SvUTF8_on(sv); /* shrink the sv if we allocated more than we used */ @@ -1599,9 +1585,9 @@ 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, (PL_lex_inpat ? "qr" : "q"), sv, Nullsv, - ( PL_lex_inwhat == OP_TRANS + ( PL_lex_inwhat == OP_TRANS ? "tr" : ( (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat) ? "s" @@ -1872,7 +1858,7 @@ S_incl_perldb(pTHX) /* Encoded script support. filter_add() effectively inserts a - * 'pre-processing' function into the current source input stream. + * 'pre-processing' function into the current source input stream. * Note that the filter function only applies to the current source file * (e.g., it will not affect files 'require'd or 'use'd by this one). * @@ -1908,7 +1894,7 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) av_store(PL_rsfp_filters, 0, datasv) ; return(datasv); } - + /* Delete most recently added instance of this filter function. */ void @@ -1935,8 +1921,8 @@ Perl_filter_del(pTHX_ filter_t funcp) /* Invoke the n'th filter function for the current rsfp. */ I32 Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) - - + + /* 0 = read one text line */ { filter_t funcp; @@ -1949,7 +1935,7 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) /* Note that we append to the line. This is handy. */ DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: from rsfp\n", idx)); - if (maxlen) { + if (maxlen) { /* Want a block */ int len ; int old_len = SvCUR(buf_sv) ; @@ -2071,40 +2057,40 @@ S_find_in_my_stash(pTHX_ char *pkgname, I32 len) if we already built the token before, use it. */ +#ifdef USE_PURE_BISON #ifdef __SC__ -#pragma segment Perl_yylex +#pragma segment Perl_yylex_r #endif int -#ifdef USE_PURE_BISON -Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp) -#else -Perl_yylex(pTHX) -#endif +Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp) { - dTHR; int r; -#ifdef USE_PURE_BISON yylval_pointer[yyactlevel] = lvalp; yychar_pointer[yyactlevel] = lcharp; yyactlevel++; if (yyactlevel >= YYMAXLEVEL) Perl_croak(aTHX_ "panic: YYMAXLEVEL"); -#endif - r = S_syylex(aTHX); + r = Perl_yylex(aTHX); -#ifdef USE_PURE_BISON yyactlevel--; -#endif return r; } +#endif -STATIC int -S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ +#ifdef __SC__ +#pragma segment Perl_yylex +#endif + +int +#ifdef USE_PURE_BISON +Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp) +#else +Perl_yylex(pTHX) +#endif { - dTHR; register char *s; register char *d; register I32 tmp; @@ -2118,6 +2104,9 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ char pit = PL_pending_ident; PL_pending_ident = 0; + DEBUG_T({ PerlIO_printf(Perl_debug_log, + "### Tokener saw identifier '%s'\n", PL_tokenbuf); }) + /* if we're in a my(), we can't allow dynamics here. $foo'bar has already been turned into $foo::bar, so just check for colons. @@ -2142,7 +2131,7 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ } } - /* + /* build the ops for accesses to a my() variable. Deny my($a) or my($b) in a sort block, *if* $a or $b is @@ -2255,6 +2244,10 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ PL_expect = PL_lex_expect; PL_lex_defer = LEX_NORMAL; } + DEBUG_T({ PerlIO_printf(Perl_debug_log, + "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr, + (IV)PL_nexttype[PL_nexttoke]); }) + return(PL_nexttype[PL_nexttoke]); /* interpolated case modifiers like \L \U, including \Q and \E. @@ -2286,6 +2279,8 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ return yylex(); } else { + DEBUG_T({ PerlIO_printf(Perl_debug_log, + "### Saw case modifier at '%s'\n", PL_bufptr); }) s = PL_bufptr + 1; if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3)) tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */ @@ -2336,6 +2331,8 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ case LEX_INTERPSTART: if (PL_bufptr == PL_bufend) return sublex_done(); + DEBUG_T({ PerlIO_printf(Perl_debug_log, + "### Interpolated variable at '%s'\n", PL_bufptr); }) PL_expect = XTERM; PL_lex_dojoin = (*PL_bufptr == '@'); PL_lex_state = LEX_INTERPNORMAL; @@ -2432,7 +2429,7 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ s = PL_bufptr; PL_oldoldbufptr = PL_oldbufptr; PL_oldbufptr = s; - DEBUG_p( { + DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n", exp_name[PL_expect], s); } ) @@ -2452,6 +2449,9 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ PL_last_lop = 0; if (PL_lex_brackets) yyerror("Missing right curly or square bracket"); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Tokener got EOF\n"); + } ) TOKEN(0); } if (s++ < PL_bufend) @@ -2517,8 +2517,32 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ goto retry; } do { - bool bof; - bof = PL_rsfp && (PerlIO_tell(PL_rsfp) == 0); /* *Before* read! */ + bool bof = PL_rsfp ? TRUE : FALSE; + if (bof) { +#ifdef PERLIO_IS_STDIO +# ifdef __GNU_LIBRARY__ +# if __GNU_LIBRARY__ == 1 /* Linux glibc5 */ +# define FTELL_FOR_PIPE_IS_BROKEN +# endif +# else +# ifdef __GLIBC__ +# if __GLIBC__ == 1 /* maybe some glibc5 release had it like this? */ +# define FTELL_FOR_PIPE_IS_BROKEN +# endif +# endif +# endif +#endif +#ifdef FTELL_FOR_PIPE_IS_BROKEN + /* This loses the possibility to detect the bof + * situation on perl -P when the libc5 is being used. + * Workaround? Maybe attach some extra state to PL_rsfp? + */ + if (!PL_preprocess) + bof = PerlIO_tell(PL_rsfp) == 0; +#else + bof = PerlIO_tell(PL_rsfp) == 0; +#endif + } s = filter_gets(PL_linestr, PL_rsfp, 0); if (s == Nullch) { fake_eof: @@ -2558,7 +2582,7 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); PL_doextract = FALSE; } - } + } incline(s); } while (PL_doextract); PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s; @@ -2683,7 +2707,7 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ else newargv = PL_origargv; newargv[0] = ipath; - PerlProc_execv(ipath, newargv); + PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv)); Perl_croak(aTHX_ "Can't exec %s", ipath); } #endif @@ -2731,7 +2755,7 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ case '\r': #ifdef PERL_STRICT_CR Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r'); - Perl_croak(aTHX_ + Perl_croak(aTHX_ "\t(Maybe you didn't strip carriage returns after a network transfer?)\n"); #endif case ' ': case '\t': case '\f': case 013: @@ -2767,6 +2791,8 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ goto retry; case '-': if (s[1] && isALPHA(s[1]) && !isALNUM(s[2])) { + I32 ftst = 0; + s++; PL_bufptr = s; tmp = *s++; @@ -2776,42 +2802,64 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ if (strnEQ(s,"=>",2)) { s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw unary minus before =>, forcing word '%s'\n", s); + } ) OPERATOR('-'); /* unary minus */ } PL_last_uni = PL_oldbufptr; - PL_last_lop_op = OP_FTEREAD; /* good enough */ switch (tmp) { - case 'r': FTST(OP_FTEREAD); - case 'w': FTST(OP_FTEWRITE); - case 'x': FTST(OP_FTEEXEC); - case 'o': FTST(OP_FTEOWNED); - case 'R': FTST(OP_FTRREAD); - case 'W': FTST(OP_FTRWRITE); - case 'X': FTST(OP_FTREXEC); - case 'O': FTST(OP_FTROWNED); - case 'e': FTST(OP_FTIS); - case 'z': FTST(OP_FTZERO); - case 's': FTST(OP_FTSIZE); - case 'f': FTST(OP_FTFILE); - case 'd': FTST(OP_FTDIR); - case 'l': FTST(OP_FTLINK); - case 'p': FTST(OP_FTPIPE); - case 'S': FTST(OP_FTSOCK); - case 'u': FTST(OP_FTSUID); - case 'g': FTST(OP_FTSGID); - case 'k': FTST(OP_FTSVTX); - case 'b': FTST(OP_FTBLK); - case 'c': FTST(OP_FTCHR); - case 't': FTST(OP_FTTTY); - case 'T': FTST(OP_FTTEXT); - case 'B': FTST(OP_FTBINARY); - case 'M': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTMTIME); - case 'A': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTATIME); - case 'C': gv_fetchpv("\024",TRUE, SVt_PV); FTST(OP_FTCTIME); + case 'r': ftst = OP_FTEREAD; break; + case 'w': ftst = OP_FTEWRITE; break; + case 'x': ftst = OP_FTEEXEC; break; + case 'o': ftst = OP_FTEOWNED; break; + case 'R': ftst = OP_FTRREAD; break; + case 'W': ftst = OP_FTRWRITE; break; + case 'X': ftst = OP_FTREXEC; break; + case 'O': ftst = OP_FTROWNED; break; + case 'e': ftst = OP_FTIS; break; + case 'z': ftst = OP_FTZERO; break; + case 's': ftst = OP_FTSIZE; break; + case 'f': ftst = OP_FTFILE; break; + case 'd': ftst = OP_FTDIR; break; + case 'l': ftst = OP_FTLINK; break; + case 'p': ftst = OP_FTPIPE; break; + case 'S': ftst = OP_FTSOCK; break; + case 'u': ftst = OP_FTSUID; break; + case 'g': ftst = OP_FTSGID; break; + case 'k': ftst = OP_FTSVTX; break; + case 'b': ftst = OP_FTBLK; break; + case 'c': ftst = OP_FTCHR; break; + case 't': ftst = OP_FTTTY; break; + case 'T': ftst = OP_FTTEXT; break; + case 'B': ftst = OP_FTBINARY; break; + case 'M': case 'A': case 'C': + gv_fetchpv("\024",TRUE, SVt_PV); + switch (tmp) { + case 'M': ftst = OP_FTMTIME; break; + case 'A': ftst = OP_FTATIME; break; + case 'C': ftst = OP_FTCTIME; break; + default: break; + } + break; default: - Perl_croak(aTHX_ "Unrecognized file test: -%c", (int)tmp); break; } + if (ftst) { + PL_last_lop_op = ftst; + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw file test %c\n", ftst); + } ) + FTST(ftst); + } + else { + /* Assume it was a minus followed by a one-letter named + * subroutine call (or a -bareword), then. */ + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### %c looked like a file test but was not\n", ftst); + } ) + s -= 2; + } } tmp = *s++; if (*s == tmp) { @@ -3509,8 +3557,8 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ case '?': /* may either be conditional or pattern */ if (PL_expect != XOPERATOR) { /* Disable warning on "study /blah/" */ - if (PL_oldoldbufptr == PL_last_uni - && (*PL_last_uni != 's' || s - PL_last_uni < 5 + if (PL_oldoldbufptr == PL_last_uni + && (*PL_last_uni != 's' || s - PL_last_uni < 5 || memNE(PL_last_uni, "study", 5) || isALNUM_lazy_if(PL_last_uni+5,UTF))) check_uni(); @@ -3555,12 +3603,18 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': s = scan_num(s, &yylval); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw number in '%s'\n", s); + } ) if (PL_expect == XOPERATOR) no_op("Number",s); TERM(THING); case '\'': s = scan_str(s,FALSE,FALSE); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw string in '%s'\n", s); + } ) if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; @@ -3577,6 +3631,9 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ case '"': s = scan_str(s,FALSE,FALSE); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw string in '%s'\n", s); + } ) if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; @@ -3599,6 +3656,9 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ case '`': s = scan_str(s,FALSE,FALSE); + DEBUG_T( { PerlIO_printf(Perl_debug_log, + "### Saw backtick string in '%s'\n", s); + } ) if (PL_expect == XOPERATOR) no_op("Backticks",s); if (!s) @@ -3798,7 +3858,7 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':') { if (ckWARN(WARN_BAREWORD) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV)) - Perl_warner(aTHX_ WARN_BAREWORD, + Perl_warner(aTHX_ WARN_BAREWORD, "Bareword \"%s\" refers to nonexistent package", PL_tokenbuf); len -= 2; @@ -4194,7 +4254,7 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ case KEY_exists: UNI(OP_EXISTS); - + case KEY_exit: UNI(OP_EXIT); @@ -4398,7 +4458,7 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ case KEY_last: s = force_word(s,WORD,TRUE,FALSE,FALSE); LOOPX(OP_LAST); - + case KEY_lc: UNI(OP_LC); @@ -4543,7 +4603,7 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ case KEY_pos: UNI(OP_POS); - + case KEY_pack: LOP(OP_PACK,XTERM); @@ -4705,7 +4765,7 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ case KEY_chomp: UNI(OP_CHOMP); - + case KEY_scalar: UNI(OP_SCALAR); @@ -4994,7 +5054,7 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ case KEY_umask: if (ckWARN(WARN_UMASK)) { for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ; - if (*d != '0' && isDIGIT(*d)) + if (*d != '0' && isDIGIT(*d)) Perl_warner(aTHX_ WARN_UMASK, "umask: argument is missing initial 0"); } @@ -5049,7 +5109,7 @@ S_syylex(pTHX) /* need to be separate from yylex for reentrancy */ { static char ctl_l[2]; - if (ctl_l[0] == '\0') + if (ctl_l[0] == '\0') ctl_l[0] = toCTRL('L'); gv_fetchpv(ctl_l,TRUE, SVt_PV); } @@ -5195,7 +5255,7 @@ Perl_keyword(pTHX_ register char *d, I32 len) if (strEQ(d,"exit")) return -KEY_exit; if (strEQ(d,"eval")) return KEY_eval; if (strEQ(d,"exec")) return -KEY_exec; - if (strEQ(d,"each")) return KEY_each; + if (strEQ(d,"each")) return -KEY_each; break; case 5: if (strEQ(d,"elsif")) return KEY_elsif; @@ -5339,7 +5399,7 @@ Perl_keyword(pTHX_ register char *d, I32 len) break; case 'k': if (len == 4) { - if (strEQ(d,"keys")) return KEY_keys; + if (strEQ(d,"keys")) return -KEY_keys; if (strEQ(d,"kill")) return -KEY_kill; } break; @@ -5421,11 +5481,11 @@ Perl_keyword(pTHX_ register char *d, I32 len) case 'p': switch (len) { case 3: - if (strEQ(d,"pop")) return KEY_pop; + if (strEQ(d,"pop")) return -KEY_pop; if (strEQ(d,"pos")) return KEY_pos; break; case 4: - if (strEQ(d,"push")) return KEY_push; + if (strEQ(d,"push")) return -KEY_push; if (strEQ(d,"pack")) return -KEY_pack; if (strEQ(d,"pipe")) return -KEY_pipe; break; @@ -5532,7 +5592,7 @@ Perl_keyword(pTHX_ register char *d, I32 len) case 'h': switch (len) { case 5: - if (strEQ(d,"shift")) return KEY_shift; + if (strEQ(d,"shift")) return -KEY_shift; break; case 6: if (strEQ(d,"shmctl")) return -KEY_shmctl; @@ -5561,7 +5621,7 @@ Perl_keyword(pTHX_ register char *d, I32 len) case 'p': if (strEQ(d,"split")) return KEY_split; if (strEQ(d,"sprintf")) return -KEY_sprintf; - if (strEQ(d,"splice")) return KEY_splice; + if (strEQ(d,"splice")) return -KEY_splice; break; case 'q': if (strEQ(d,"sqrt")) return -KEY_sqrt; @@ -5641,7 +5701,7 @@ Perl_keyword(pTHX_ register char *d, I32 len) if (strEQ(d,"unlink")) return -KEY_unlink; break; case 7: - if (strEQ(d,"unshift")) return KEY_unshift; + if (strEQ(d,"unshift")) return -KEY_unshift; if (strEQ(d,"ucfirst")) return -KEY_ucfirst; break; } @@ -5687,7 +5747,6 @@ S_checkcomma(pTHX_ register char *s, char *name, char *what) char *w; if (*s == ' ' && s[1] == '(') { /* XXX gotta be a better way */ - dTHR; /* only for ckWARN */ if (ckWARN(WARN_SYNTAX)) { int level = 1; for (w = s+2; *w && level; w++) { @@ -5742,18 +5801,27 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, SV **cvp; SV *cv, *typesv; const char *why1, *why2, *why3; - + if (!table || !(PL_hints & HINT_LOCALIZE_HH)) { SV *msg; - why1 = "%^H is not consistent"; why2 = strEQ(key,"charnames") - ? " (missing \"use charnames ...\"?)" + ? "(possibly a missing \"use charnames ...\")" : ""; - why3 = ""; + msg = Perl_newSVpvf(aTHX_ "Constant(%s) unknown: %s", + (type ? type: "undef"), why2); + + /* This is convoluted and evil ("goto considered harmful") + * but I do not understand the intricacies of all the different + * failure modes of %^H in here. The goal here is to make + * the most probable error message user-friendly. --jhi */ + + goto msgdone; + report: - msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s", + msg = Perl_newSVpvf(aTHX_ "Constant(%s): %s%s%s", (type ? type: "undef"), why1, why2, why3); + msgdone: yyerror(SvPVX(msg)); SvREFCNT_dec(msg); return sv; @@ -5773,11 +5841,11 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, typesv = sv_2mortal(newSVpv(type, 0)); else typesv = &PL_sv_undef; - + PUSHSTACKi(PERLSI_OVERLOAD); ENTER ; SAVETMPS; - + PUSHMARK(SP) ; EXTEND(sp, 3); if (pv) @@ -5787,9 +5855,9 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, PUSHs(typesv); PUTBACK; call_sv(cv, G_SCALAR | ( PL_in_eval ? 0 : G_EVAL)); - + SPAGAIN ; - + /* Check the eval first */ if (!PL_in_eval && SvTRUE(ERRSV)) { STRLEN n_a; @@ -5802,12 +5870,12 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, res = POPs; (void)SvREFCNT_inc(res); } - + PUTBACK ; FREETMPS ; LEAVE ; POPSTACK; - + if (!SvOK(res)) { why1 = "Call to &{$^H{"; why2 = key; @@ -5818,7 +5886,7 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, return res; } - + STATIC char * S_scan_word(pTHX_ register char *s, char *dest, STRLEN destlen, int allow_package, STRLEN *slp) { @@ -5961,7 +6029,6 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des *d = '\0'; while (s < send && SPACE_OR_TAB(*s)) s++; if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { - dTHR; /* only for ckWARN */ if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) { const char *brack = *s == '[' ? "[...]" : "{...}"; Perl_warner(aTHX_ WARN_AMBIGUOUS, @@ -5972,8 +6039,8 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des PL_lex_brackstack[PL_lex_brackets++] = (char)(XOPERATOR | XFAKEBRACK); return s; } - } - /* Handle extended ${^Foo} variables + } + /* Handle extended ${^Foo} variables * 1999-02-27 mjd-perl-patch@plover.com */ else if (!isALNUM(*d) && !isPRINT(*d) /* isCTRL(d) */ && isALNUM(*s)) @@ -5993,7 +6060,6 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des if (funny == '#') funny = '@'; if (PL_lex_state == LEX_NORMAL) { - dTHR; /* only for ckWARN */ if (ckWARN(WARN_AMBIGUOUS) && (keyword(dest, d - dest) || get_cv(dest, FALSE))) { @@ -6192,7 +6258,6 @@ S_scan_trans(pTHX_ char *start) STATIC char * S_scan_heredoc(pTHX_ register char *s) { - dTHR; SV *herewas; I32 op_type = OP_SCALAR; I32 len; @@ -6527,7 +6592,7 @@ S_scan_inputsymbol(pTHX_ char *start) calls scan_str(). s/// makes yylex() call scan_subst() which calls scan_str(). tr/// and y/// make yylex() call scan_trans() which calls scan_str(). - + It skips whitespace before the string starts, and treats the first character as the delimiter. If the delimiter is one of ([{< then the corresponding "close" character )]}> is used as the closing @@ -6544,14 +6609,13 @@ S_scan_inputsymbol(pTHX_ char *start) STATIC char * S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) { - dTHR; SV *sv; /* scalar value: string */ 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 */ I32 brackets = 1; /* bracket nesting level */ - bool has_utf = FALSE; /* is there any utf8 content? */ + bool has_utf8 = FALSE; /* is there any utf8 content? */ /* skip space before the delimiter */ if (isSPACE(*s)) @@ -6563,7 +6627,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) /* after skipping whitespace, the next character is the terminator */ term = *s; if ((term & 0x80) && UTF) - has_utf = TRUE; + has_utf8 = TRUE; /* mark where we are */ PL_multi_start = CopLINE(PL_curcop); @@ -6609,8 +6673,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) have found the terminator */ else if (*s == term) break; - else if (!has_utf && (*s & 0x80) && UTF) - has_utf = TRUE; + else if (!has_utf8 && (*s & 0x80) && UTF) + has_utf8 = TRUE; *to = *s; } } @@ -6638,8 +6702,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) break; else if (*s == PL_multi_open) brackets++; - else if (!has_utf && (*s & 0x80) && UTF) - has_utf = TRUE; + else if (!has_utf8 && (*s & 0x80) && UTF) + has_utf8 = TRUE; *to = *s; } } @@ -6694,12 +6758,12 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) /* having changed the buffer, we must update PL_bufend */ PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); } - + /* at this point, we have successfully read the delimited string */ if (keep_delims) sv_catpvn(sv, s, 1); - if (has_utf) + if (has_utf8) SvUTF8_on(sv); PL_multi_end = CopLINE(PL_curcop); s++; @@ -6713,7 +6777,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) /* decide whether this is the first or second quoted string we've read for this op */ - + if (PL_lex_stuff) PL_lex_repl = sv; else @@ -6742,7 +6806,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) try converting the number to an integer and see if it can do so without loss of precision. */ - + char * Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) { @@ -6760,7 +6824,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) switch (*s) { default: Perl_croak(aTHX_ "panic: scan_num"); - + /* if it starts with a 0, it could be an octal number, a decimal in 0.13 disguise, or a hexadecimal number, or a binary number. */ case '0': @@ -6775,7 +6839,6 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) we in octal/hex/binary?" indicator to disallow hex characters when in octal mode. */ - dTHR; NV n = 0.0; UV u = 0; I32 shift; @@ -6863,7 +6926,6 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) if ((x >> shift) != u && !(PL_hints & HINT_NEW_BINARY)) { - dTHR; overflowed = TRUE; n = (NV) u; if (ckWARN_d(WARN_OVERFLOW)) @@ -6895,7 +6957,6 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) out: sv = NEWSV(92,0); if (overflowed) { - dTHR; if (ckWARN(WARN_PORTABLE) && n > 4294967295.0) Perl_warner(aTHX_ WARN_PORTABLE, "%s number > %s non-portable", @@ -6904,7 +6965,6 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) } else { #if UVSIZE > 4 - dTHR; if (ckWARN(WARN_PORTABLE) && u > 0xffffffff) Perl_warner(aTHX_ WARN_PORTABLE, "%s number > %s non-portable", @@ -6930,11 +6990,10 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) /* read next group of digits and _ and copy into d */ while (isDIGIT(*s) || *s == '_') { - /* skip underscores, checking for misplaced ones + /* skip underscores, checking for misplaced ones if -w is on */ if (*s == '_') { - dTHR; /* only for ckWARN */ if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3) Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number"); lastub = ++s; @@ -6950,7 +7009,6 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) /* final misplaced underbar check */ if (lastub && s - lastub != 3) { - dTHR; if (ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number"); } @@ -7059,7 +7117,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) compilers have issues. Then we try casting it back and see if it was the same [1]. We only do this if we know we specifically read an integer. If floatit is true, then we - don't need to do the conversion at all. + don't need to do the conversion at all. [1] Note that this is lossy if our NVs cannot preserve our UVs. There are metaconfig defines NV_PRESERVES_UV (a boolean) @@ -7070,7 +7128,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) Maybe could do some tricks with DBL_DIG, LDBL_DIG and DBL_MANT_DIG and LDBL_MANT_DIG (these are already available as NV_DIG and NV_MANT_DIG)? - + --jhi */ { @@ -7087,7 +7145,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) #endif 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, (floatit ? "float" : "integer"), sv, Nullsv, NULL); break; @@ -7102,7 +7160,7 @@ vstring: pos++; if (!isALPHA(*pos)) { UV rev; - U8 tmpbuf[UTF8_MAXLEN]; + U8 tmpbuf[UTF8_MAXLEN+1]; U8 *tmpend; bool utf8 = FALSE; s++; /* get past 'v' */ @@ -7167,7 +7225,6 @@ vstring: STATIC char * S_scan_formline(pTHX_ register char *s) { - dTHR; register char *eol; register char *t; SV *stuff = newSVpvn("",0); @@ -7258,7 +7315,6 @@ S_set_csh(pTHX) I32 Perl_start_subparse(pTHX_ I32 is_format, U32 flags) { - dTHR; I32 oldsavestack_ix = PL_savestack_ix; CV* outsidecv = PL_compcv; AV* comppadlist; @@ -7314,7 +7370,6 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) int Perl_yywarn(pTHX_ char *s) { - dTHR; PL_in_eval |= EVAL_WARNONLY; yyerror(s); PL_in_eval &= ~EVAL_WARNONLY; @@ -7324,7 +7379,6 @@ Perl_yywarn(pTHX_ char *s) int Perl_yyerror(pTHX_ char *s) { - dTHR; char *where = NULL; char *context = NULL; int contlen = -1; @@ -7408,8 +7462,8 @@ S_swallow_bom(pTHX_ U8 *s) STRLEN slen; slen = SvCUR(PL_linestr); switch (*s) { - case 0xFF: - if (s[1] == 0xFE) { + case 0xFF: + if (s[1] == 0xFE) { /* UTF-16 little-endian */ if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */ Perl_croak(aTHX_ "Unsupported script encoding"); @@ -7511,7 +7565,7 @@ utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen) if (!*SvPV_nolen(sv)) /* Game over, but don't feed an odd-length string to utf16_to_utf8 */ return count; - + tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen); sv_usepvn(sv, (char*)tmps, tend - tmps); }