X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=2b14e02afe0bb9f2acd5a43a099b239715d58fb7;hb=f81125e29831a3ead69d58ca3d58559654ea06d2;hp=e7834c4bb74c956da6d9a3055295bc4343483dbf;hpb=6e909404a2579c635b9578c0b6ce5416a5ed7b0b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index e7834c4..2b14e02 100644 --- a/toke.c +++ b/toke.c @@ -1,6 +1,7 @@ /* toke.c * - * Copyright (c) 1991-2002, Larry Wall + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, + * 2000, 2001, 2002, 2003, 2004, 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. @@ -22,8 +23,8 @@ #define PERL_IN_TOKE_C #include "perl.h" -#define yychar PL_yychar -#define yylval PL_yylval +#define yychar (*PL_yycharp) +#define yylval (*PL_yylvalp) static char ident_too_long[] = "Identifier too long"; static char c_without_g[] = "Use of /c modifier is meaningless without /g"; @@ -78,22 +79,6 @@ static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen); #undef ff_next #endif -#ifdef USE_PURE_BISON -# ifndef YYMAXLEVEL -# define YYMAXLEVEL 100 -# endif -YYSTYPE* yylval_pointer[YYMAXLEVEL]; -int* yychar_pointer[YYMAXLEVEL]; -int yyactlevel = -1; -# undef yylval -# undef yychar -# 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_r(aTHX_ yylval_pointer[yyactlevel],yychar_pointer[yyactlevel]) -#endif - #include "keywords.h" /* CLINE is a macro that ensures PL_copline has a sane value */ @@ -255,18 +240,23 @@ S_no_op(pTHX_ char *what, char *s) else PL_bufptr = s; yywarn(Perl_form(aTHX_ "%s found where operator expected", what)); - if (is_first) - Perl_warn(aTHX_ "\t(Missing semicolon on previous line?)\n"); - else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) { - char *t; - for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ; - if (t < PL_bufptr && isSPACE(*t)) - Perl_warn(aTHX_ "\t(Do you need to predeclare %.*s?)\n", - t - PL_oldoldbufptr, PL_oldoldbufptr); - } - else { - assert(s >= oldbp); - Perl_warn(aTHX_ "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp); + if (ckWARN_d(WARN_SYNTAX)) { + if (is_first) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "\t(Missing semicolon on previous line?)\n"); + else if (PL_oldoldbufptr && isIDFIRST_lazy_if(PL_oldoldbufptr,UTF)) { + char *t; + for (t = PL_oldoldbufptr; *t && (isALNUM_lazy_if(t,UTF) || *t == ':'); t++) ; + if (t < PL_bufptr && isSPACE(*t)) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "\t(Do you need to predeclare %.*s?)\n", + t - PL_oldoldbufptr, PL_oldoldbufptr); + } + else { + assert(s >= oldbp); + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp); + } } PL_bufptr = oldbp; } @@ -681,7 +671,7 @@ S_check_uni(pTHX) char ch = *s; *s = '\0'; Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS), - "Warning: Use of \"%s\" without parens is ambiguous", + "Warning: Use of \"%s\" without parentheses is ambiguous", PL_last_uni); *s = ch; } @@ -785,6 +775,8 @@ S_force_word(pTHX_ register char *start, int token, int check_keyword, int allow } PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST,0, newSVpv(PL_tokenbuf,0)); PL_nextval[PL_nexttoke].opval->op_private |= OPpCONST_BARE; + if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len)) + SvUTF8_on(((SVOP*)PL_nextval[PL_nexttoke].opval)->op_sv); force_next(token); } return s; @@ -1228,7 +1220,7 @@ S_scan_const(pTHX_ char *start) const char *leaveit = /* set of acceptably-backslashed characters */ PL_lex_inpat - ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxcz0123456789[{]} \t\n\r\f\v#" + ? "\\.^$@AGZdDwWsSbBpPXC+*?|()-nrtfeaxz0123456789[{]} \t\n\r\f\v#" : ""; if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) { @@ -1321,7 +1313,7 @@ S_scan_const(pTHX_ char *start) except for the last char, which will be done separately. */ else if (*s == '(' && PL_lex_inpat && s[1] == '?') { if (s[2] == '#') { - while (s < send && *s != ')') + while (s+1 < send && *s != ')') *d++ = NATIVE_TO_NEED(has_utf8,*s++); } else if (s[2] == '{' /* This should match regcomp.c */ @@ -1340,10 +1332,8 @@ S_scan_const(pTHX_ char *start) count--; regparse++; } - if (*regparse != ')') { + if (*regparse != ')') regparse--; /* Leave one char for continuation. */ - yyerror("Sequence (?{...}) not terminated or not {}-balanced"); - } while (s < regparse) *d++ = NATIVE_TO_NEED(has_utf8,*s++); } @@ -2141,7 +2131,7 @@ S_find_in_my_stash(pTHX_ char *pkgname, I32 len) #ifdef DEBUGGING static char* exp_name[] = { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK", - "ATTRTERM", "TERMBLOCK" + "ATTRTERM", "TERMBLOCK", "TERMORDORDOR" }; #endif @@ -2170,26 +2160,6 @@ S_find_in_my_stash(pTHX_ char *pkgname, I32 len) if we already built the token before, use it. */ -#ifdef USE_PURE_BISON -int -Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp) -{ - int r; - - yyactlevel++; - yylval_pointer[yyactlevel] = lvalp; - yychar_pointer[yyactlevel] = lcharp; - if (yyactlevel >= YYMAXLEVEL) - Perl_croak(aTHX_ "panic: YYMAXLEVEL"); - - r = Perl_yylex(aTHX); - - if (yyactlevel > 0) - yyactlevel--; - - return r; -} -#endif #ifdef __SC__ #pragma segment Perl_yylex @@ -2426,8 +2396,12 @@ Perl_yylex(pTHX) if (!PL_rsfp) { PL_last_uni = 0; PL_last_lop = 0; - if (PL_lex_brackets) - yyerror("Missing right curly or square bracket"); + if (PL_lex_brackets) { + if (PL_lex_formbrack) + yyerror("Format not terminated"); + else + yyerror("Missing right curly or square bracket"); + } DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Tokener got EOF\n"); } ); @@ -2523,8 +2497,13 @@ Perl_yylex(pTHX) sv_setpv(PL_linestr,""); TOKEN(';'); /* not infinite loop because rsfp is NULL now */ } - /* if it looks like the start of a BOM, check if it in fact is */ - else if (bof && (!*s || *(U8*)s == 0xEF || *(U8*)s >= 0xFE)) { + /* If it looks like the start of a BOM or raw UTF-16, + * check if it in fact is. */ + else if (bof && + (*s == 0 || + *(U8*)s == 0xEF || + *(U8*)s >= 0xFE || + s[1] == 0)) { #ifdef PERLIO_IS_STDIO # ifdef __GNU_LIBRARY__ # if __GNU_LIBRARY__ == 1 /* Linux glibc5 */ @@ -2703,7 +2682,9 @@ Perl_yylex(pTHX) else newargv = PL_origargv; newargv[0] = ipath; + PERL_FPU_PRE_EXEC PerlProc_execv(ipath, EXEC_ARGV_CAST(newargv)); + PERL_FPU_POST_EXEC Perl_croak(aTHX_ "Can't exec %s", ipath); } #endif @@ -2726,6 +2707,14 @@ Perl_yylex(pTHX) } d = moreswitches(d); } while (d); + if (PL_doswitches && !switches_done) { + int argc = PL_origargc; + char **argv = PL_origargv; + do { + argc--,argv++; + } while (argc && argv[0][0] == '-' && argv[0][1]); + init_argv_symbols(argc,argv); + } if ((PERLDB_LINE && !oldpdb) || ((PL_minus_n || PL_minus_p) && !(oldn || oldp))) /* if we have already added "LINE: while (<>) {", @@ -2864,10 +2853,10 @@ Perl_yylex(pTHX) /* 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", - (int)ftst); + "### '-%c' looked like a file test but was not\n", + tmp); } ); - s -= 2; + s = --PL_bufptr; } } tmp = *s++; @@ -2939,8 +2928,6 @@ Perl_yylex(pTHX) PL_tokenbuf[0] = '%'; s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, TRUE); if (!PL_tokenbuf[1]) { - if (s == PL_bufend) - yyerror("Final % should be \\% or %name"); PREREF('%'); } PL_pending_ident = '%'; @@ -3017,19 +3004,27 @@ Perl_yylex(pTHX) PL_lex_stuff = Nullsv; } else { + if (len == 6 && strnEQ(s, "unique", len)) { + if (PL_in_my == KEY_our) +#ifdef USE_ITHREADS + GvUNIQUE_on(cGVOPx_gv(yylval.opval)); +#else + ; /* skip to avoid loading attributes.pm */ +#endif + else + Perl_croak(aTHX_ "The 'unique' attribute may only be applied to 'our' variables"); + } + /* NOTE: any CV attrs applied here need to be part of the CVf_BUILTIN_ATTRS define in cv.h! */ - if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len)) + else if (!PL_in_my && len == 6 && strnEQ(s, "lvalue", len)) CvLVALUE_on(PL_compcv); else if (!PL_in_my && len == 6 && strnEQ(s, "locked", len)) CvLOCKED_on(PL_compcv); else if (!PL_in_my && len == 6 && strnEQ(s, "method", len)) CvMETHOD_on(PL_compcv); -#ifdef USE_ITHREADS - else if (PL_in_my == KEY_our && len == 6 && - strnEQ(s, "unique", len)) - GvUNIQUE_on(cGVOPx_gv(yylval.opval)); -#endif + else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len)) + CvASSERTION_on(PL_compcv); /* After we've set the flags, it could be argued that we don't need to do the attributes.pm-based setting process, and shouldn't bother appending recognized @@ -3086,6 +3081,7 @@ Perl_yylex(pTHX) PL_oldbufptr = PL_oldoldbufptr; /* allow print(STDOUT 123) */ else PL_expect = XTERM; + s = skipspace(s); TOKEN('('); case ';': CLINE; @@ -3207,12 +3203,17 @@ Perl_yylex(pTHX) || ((*t == 'q' || *t == 'x') && ++t < PL_bufend && !isALNUM(*t)))) { + /* skip q//-like construct */ char *tmps; char open, close, term; I32 brackets = 1; while (t < PL_bufend && isSPACE(*t)) t++; + /* check for q => */ + if (t+1 < PL_bufend && t[0] == '=' && t[1] == '>') { + OPERATOR(HASHBRACK); + } term = *t; open = term; if (term && (tmps = strchr("([{< )]}> )]}>",term))) @@ -3225,7 +3226,7 @@ Perl_yylex(pTHX) else if (*t == open) break; } - else + else { for (t++; t < PL_bufend; t++) { if (*t == '\\' && t+1 < PL_bufend) t++; @@ -3234,8 +3235,13 @@ Perl_yylex(pTHX) else if (*t == open) brackets++; } + } + t++; } - t++; + else + /* skip plain q word */ + while (t < PL_bufend && isALNUM_lazy_if(t,UTF)) + t += UTF8SKIP(t); } else if (isALNUM_lazy_if(t,UTF)) { t += UTF8SKIP(t); @@ -3381,8 +3387,24 @@ Perl_yylex(pTHX) case '!': s++; tmp = *s++; - if (tmp == '=') + if (tmp == '=') { + /* was this !=~ where !~ was meant? + * warn on m:!=~\s+([/?]|[msy]\W|tr\W): */ + + if (*s == '~' && ckWARN(WARN_SYNTAX)) { + char *t = s+1; + + while (t < PL_bufend && isSPACE(*t)) + ++t; + + if (*t == '/' || *t == '?' || + ((*t == 'm' || *t == 's' || *t == 'y') && !isALNUM(t[1])) || + (*t == 't' && t[1] == 'r' && !isALNUM(t[2]))) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "!=~ should be !~"); + } Eop(OP_NE); + } if (tmp == '~') PMop(OP_NOT); s--; @@ -3535,9 +3557,7 @@ Perl_yylex(pTHX) } } else { - GV *gv = gv_fetchpv(tmpbuf, FALSE, SVt_PVCV); - if (gv && GvCVu(gv)) - PL_expect = XTERM; /* e.g. print $fh subr() */ + PL_expect = XTERM; /* e.g. print $fh subr() */ } } else if (isDIGIT(*s)) @@ -3561,8 +3581,6 @@ Perl_yylex(pTHX) PL_tokenbuf[0] = '@'; s = scan_ident(s, PL_bufend, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE); if (!PL_tokenbuf[1]) { - if (s == PL_bufend) - yyerror("Final @ should be \\@ or @name"); PREREF('@'); } if (PL_lex_state == LEX_NORMAL) @@ -4072,6 +4090,8 @@ Perl_yylex(pTHX) TERM(FUNC0SUB); if (strEQ(proto, "$")) OPERATOR(UNIOPSUB); + while (*proto == ';') + proto++; if (*proto == '&' && *s == '{') { sv_setpv(PL_subname, PL_curstash ? "__ANON__" : "__ANON__::__ANON__"); @@ -4186,8 +4206,29 @@ Perl_yylex(pTHX) } #endif #ifdef PERLIO_LAYERS - if (UTF && !IN_BYTES) - PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8"); + if (!IN_BYTES) { + if (UTF) + PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8"); + else if (PL_encoding) { + SV *name; + dSP; + ENTER; + SAVETMPS; + PUSHMARK(sp); + EXTEND(SP, 1); + XPUSHs(PL_encoding); + PUTBACK; + call_method("name", G_SCALAR); + SPAGAIN; + name = POPs; + PUTBACK; + PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, + Perl_form(aTHX_ ":encoding(%"SVf")", + name)); + FREETMPS; + LEAVE; + } + } #endif PL_rsfp = Nullfp; } @@ -4645,8 +4686,8 @@ Perl_yylex(pTHX) if (isIDFIRST_lazy_if(s,UTF)) { char *t; for (d = s; isALNUM_lazy_if(d,UTF); d++) ; - t = skipspace(d); - if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE) + for (t=d; *t && isSPACE(*t); t++) ; + if ( *t && strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_PRECEDENCE) /* [perl #16184] */ && !(t[0] == '=' && t[1] == '>') ) { @@ -5054,8 +5095,12 @@ Perl_yylex(pTHX) if (*s == ':' && s[1] != ':') PL_expect = attrful; - else if (!have_name && *s != '{' && key == KEY_sub) - Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine"); + else if (*s != '{' && key == KEY_sub) { + if (!have_name) + Perl_croak(aTHX_ "Illegal declaration of anonymous subroutine"); + else if (*s != ';') + Perl_croak(aTHX_ "Illegal declaration of subroutine %"SVf, PL_subname); + } if (have_proto) { PL_nextval[PL_nexttoke].opval = @@ -5239,7 +5284,7 @@ static int S_pending_ident(pTHX) { register char *d; - register I32 tmp; + register I32 tmp = 0; /* pit holds the identifier we read and pending_ident is reset */ char pit = PL_pending_ident; PL_pending_ident = 0; @@ -5481,7 +5526,9 @@ Perl_keyword(pTHX_ register char *d, I32 len) break; case 6: if (strEQ(d,"exists")) return KEY_exists; - if (strEQ(d,"elseif")) Perl_warn(aTHX_ "elseif should be elsif"); + if (strEQ(d,"elseif") && ckWARN_d(WARN_SYNTAX)) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), + "elseif should be elsif"); break; case 8: if (strEQ(d,"endgrent")) return -KEY_endgrent; @@ -6274,8 +6321,10 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des } if (*s == '}') { s++; - if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) + if (PL_lex_state == LEX_INTERPNORMAL && !PL_lex_brackets) { PL_lex_state = LEX_INTERPEND; + PL_expect = XREF; + } if (funny == '#') funny = '@'; if (PL_lex_state == LEX_NORMAL) { @@ -6462,7 +6511,8 @@ S_scan_trans(pTHX_ char *start) New(803, tbl, complement&&!del?258:256, short); o = newPVOP(OP_TRANS, 0, (char*)tbl); - o->op_private = del|squash|complement| + o->op_private &= ~OPpTRANS_ALL; + o->op_private |= del|squash|complement| (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)| (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF : 0); @@ -6662,8 +6712,12 @@ retval: Renew(SvPVX(tmpstr), SvLEN(tmpstr), char); } SvREFCNT_dec(herewas); - if (UTF && !IN_BYTES && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr))) - SvUTF8_on(tmpstr); + if (!IN_BYTES) { + if (UTF && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr))) + SvUTF8_on(tmpstr); + else if (PL_encoding) + sv_recode_to_utf8(tmpstr, PL_encoding); + } PL_lex_stuff = tmpstr; yylval.ival = op_type; return s; @@ -6882,6 +6936,10 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) register char *to; /* current position in the sv's data */ I32 brackets = 1; /* bracket nesting level */ bool has_utf8 = FALSE; /* is there any utf8 content? */ + I32 termcode; /* terminating char. code */ + U8 termstr[UTF8_MAXLEN]; /* terminating string */ + STRLEN termlen; /* length of terminating string */ + char *last = NULL; /* last position for nesting bracket */ /* skip space before the delimiter */ if (isSPACE(*s)) @@ -6892,8 +6950,16 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) /* after skipping whitespace, the next character is the terminator */ term = *s; - if (!UTF8_IS_INVARIANT((U8)term) && UTF) - has_utf8 = TRUE; + if (!UTF) { + termcode = termstr[0] = term; + termlen = 1; + } + else { + termcode = utf8_to_uvchr((U8*)s, &termlen); + Copy(s, termstr, termlen, U8); + if (!UTF8_IS_INVARIANT(term)) + has_utf8 = TRUE; + } /* mark where we are */ PL_multi_start = CopLINE(PL_curcop); @@ -6901,21 +6967,92 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) /* find corresponding closing delimiter */ if (term && (tmps = strchr("([{< )]}> )]}>",term))) - term = tmps[5]; + termcode = termstr[0] = term = tmps[5]; + PL_multi_close = term; /* create a new SV to hold the contents. 87 is leak category, I'm assuming. 79 is the SV's initial length. What a random number. */ sv = NEWSV(87,79); sv_upgrade(sv, SVt_PVIV); - SvIVX(sv) = term; + SvIVX(sv) = termcode; (void)SvPOK_only(sv); /* validate pointer */ /* move past delimiter and try to read a complete string */ if (keep_delims) - sv_catpvn(sv, s, 1); - s++; + sv_catpvn(sv, s, termlen); + s += termlen; for (;;) { + if (PL_encoding && !UTF) { + bool cont = TRUE; + + while (cont) { + int offset = s - SvPVX(PL_linestr); + bool found = sv_cat_decode(sv, PL_encoding, PL_linestr, + &offset, (char*)termstr, termlen); + char *ns = SvPVX(PL_linestr) + offset; + char *svlast = SvEND(sv) - 1; + + for (; s < ns; s++) { + if (*s == '\n' && !PL_rsfp) + CopLINE_inc(PL_curcop); + } + if (!found) + goto read_more_line; + else { + /* handle quoted delimiters */ + if (SvCUR(sv) > 1 && *(svlast-1) == '\\') { + char *t; + for (t = svlast-2; t >= SvPVX(sv) && *t == '\\';) + t--; + if ((svlast-1 - t) % 2) { + if (!keep_quoted) { + *(svlast-1) = term; + *svlast = '\0'; + SvCUR_set(sv, SvCUR(sv) - 1); + } + continue; + } + } + if (PL_multi_open == PL_multi_close) { + cont = FALSE; + } + else { + char *t, *w; + if (!last) + last = SvPVX(sv); + for (w = t = last; t < svlast; w++, t++) { + /* At here, all closes are "was quoted" one, + so we don't check PL_multi_close. */ + if (*t == '\\') { + if (!keep_quoted && *(t+1) == PL_multi_open) + t++; + else + *w++ = *t++; + } + else if (*t == PL_multi_open) + brackets++; + + *w = *t; + } + if (w < t) { + *w++ = term; + *w = '\0'; + SvCUR_set(sv, w - SvPVX(sv)); + } + last = w; + if (--brackets <= 0) + cont = FALSE; + } + } + } + if (!keep_delims) { + SvCUR_set(sv, SvCUR(sv) - 1); + *SvEND(sv) = '\0'; + } + break; + } + /* extend sv if need be */ SvGROW(sv, SvCUR(sv) + (PL_bufend - s) + 1); /* set 'to' to the next character in the sv's string */ @@ -6937,8 +7074,12 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) } /* terminate when run out of buffer (the for() condition), or have found the terminator */ - else if (*s == term) - break; + else if (*s == term) { + if (termlen == 1) + break; + if (s+termlen <= PL_bufend && memEQ(s, (char*)termstr, termlen)) + break; + } else if (!has_utf8 && !UTF8_IS_INVARIANT((U8)*s) && UTF) has_utf8 = TRUE; *to = *s; @@ -7000,6 +7141,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) to[-1] = '\n'; #endif + read_more_line: /* if we're out of file, or a read fails, bail and reset the current line marker so we can report where the unterminated string began */ @@ -7030,15 +7172,15 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) /* at this point, we have successfully read the delimited string */ - if (keep_delims) - sv_catpvn(sv, s, 1); - if (has_utf8) + if (!PL_encoding || UTF) { + if (keep_delims) + sv_catpvn(sv, s, termlen); + s += termlen; + } + if (has_utf8 || PL_encoding) SvUTF8_on(sv); - else if (PL_encoding) - sv_recode_to_utf8(sv, PL_encoding); PL_multi_end = CopLINE(PL_curcop); - s++; /* if we allocated too much space, give some back */ if (SvCUR(sv) + 5 < SvLEN(sv)) { @@ -7115,6 +7257,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) UV u = 0; I32 shift; bool overflowed = FALSE; + bool just_zero = TRUE; /* just plain 0 or binary number? */ static NV nvshift[5] = { 1.0, 2.0, 4.0, 8.0, 16.0 }; static char* bases[5] = { "", "binary", "", "octal", "hexadecimal" }; @@ -7131,9 +7274,11 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) if (s[1] == 'x') { shift = 4; s += 2; + just_zero = FALSE; } else if (s[1] == 'b') { shift = 1; s += 2; + just_zero = FALSE; } /* check for a decimal in disguise */ else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E') @@ -7205,6 +7350,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) */ digit: + just_zero = FALSE; if (!overflowed) { x = u << shift; /* make room for the digit */ @@ -7263,7 +7409,10 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) #endif sv_setuv(sv, u); } - if (PL_hints & HINT_NEW_BINARY) + if (just_zero && (PL_hints & HINT_NEW_INTEGER)) + sv = new_constant(start, s - start, "integer", + sv, Nullsv, NULL); + else if (PL_hints & HINT_NEW_BINARY) sv = new_constant(start, s - start, "binary", sv, Nullsv, NULL); } break; @@ -7459,20 +7608,23 @@ S_scan_formline(pTHX_ register char *s) register char *t; SV *stuff = newSVpvn("",0); bool needargs = FALSE; + bool eofmt = FALSE; while (!needargs) { - if (*s == '.' || *s == /*{*/'}') { + if (*s == '.') { /*SUPPRESS 530*/ #ifdef PERL_STRICT_CR for (t = s+1;SPACE_OR_TAB(*t); t++) ; #else for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ; #endif - if (*t == '\n' || t == PL_bufend) + if (*t == '\n' || t == PL_bufend) { + eofmt = TRUE; break; + } } if (PL_in_eval && !PL_rsfp) { - eol = strchr(s,'\n'); + eol = memchr(s,'\n',PL_bufend-s); if (!eol++) eol = PL_bufend; } @@ -7509,7 +7661,6 @@ S_scan_formline(pTHX_ register char *s) PL_last_lop = PL_last_uni = Nullch; if (!s) { s = PL_bufptr; - yyerror("Format not terminated"); break; } } @@ -7525,6 +7676,12 @@ S_scan_formline(pTHX_ register char *s) } else PL_lex_state = LEX_FORMLINE; + if (!IN_BYTES) { + if (UTF && is_utf8_string((U8*)SvPVX(stuff), SvCUR(stuff))) + SvUTF8_on(stuff); + else if (PL_encoding) + sv_recode_to_utf8(stuff, PL_encoding); + } PL_nextval[PL_nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, stuff); force_next(THING); PL_nextval[PL_nexttoke].ival = OP_FORMLINE; @@ -7532,7 +7689,8 @@ S_scan_formline(pTHX_ register char *s) } else { SvREFCNT_dec(stuff); - PL_lex_formbrack = 0; + if (eofmt) + PL_lex_formbrack = 0; PL_bufptr = s; } return s; @@ -7628,12 +7786,7 @@ 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 + else if (yychar == -2) { /* YYEMPTY */ if (PL_lex_state == LEX_NORMAL || (PL_lex_state == LEX_KNOWNEXT && PL_lex_defer == LEX_NORMAL)) where = "at end of line"; @@ -7665,8 +7818,8 @@ Perl_yyerror(pTHX_ char *s) (int)PL_multi_open,(int)PL_multi_close,(IV)PL_multi_start); PL_multi_end = 0; } - if (PL_in_eval & EVAL_WARNONLY) - Perl_warn(aTHX_ "%"SVf, msg); + if (PL_in_eval & EVAL_WARNONLY && ckWARN_d(WARN_SYNTAX)) + Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "%"SVf, msg); else qerror(msg); if (PL_error_count >= 10) { @@ -7690,72 +7843,94 @@ S_swallow_bom(pTHX_ U8 *s) { STRLEN slen; slen = SvCUR(PL_linestr); - switch (*s) { + switch (s[0]) { case 0xFF: if (s[1] == 0xFE) { - /* UTF-16 little-endian */ + /* UTF-16 little-endian? (or UTF32-LE?) */ if (s[2] == 0 && s[3] == 0) /* UTF-32 little-endian */ - Perl_croak(aTHX_ "Unsupported script encoding"); + Perl_croak(aTHX_ "Unsupported script encoding UTF32-LE"); #ifndef PERL_NO_UTF16_FILTER - DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n")); + if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF16-LE script encoding (BOM)\n"); s += 2; + utf16le: if (PL_bufend > (char*)s) { U8 *news; I32 newlen; filter_add(utf16rev_textfilter, NULL); New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8); - PL_bufend = (char*)utf16_to_utf8_reversed(s, news, - PL_bufend - (char*)s - 1, - &newlen); - Copy(news, s, newlen, U8); - SvCUR_set(PL_linestr, newlen); - PL_bufend = SvPVX(PL_linestr) + newlen; - news[newlen++] = '\0'; + PL_bufend = + (char*)utf16_to_utf8_reversed(s, news, + PL_bufend - (char*)s - 1, + &newlen); + sv_setpvn(PL_linestr, (const char*)news, newlen); Safefree(news); + SvUTF8_on(PL_linestr); + s = (U8*)SvPVX(PL_linestr); + PL_bufend = SvPVX(PL_linestr) + newlen; } #else - Perl_croak(aTHX_ "Unsupported script encoding"); + Perl_croak(aTHX_ "Unsupported script encoding UTF16-LE"); #endif } break; case 0xFE: - if (s[1] == 0xFF) { /* UTF-16 big-endian */ + if (s[1] == 0xFF) { /* UTF-16 big-endian? */ #ifndef PERL_NO_UTF16_FILTER - DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n")); + if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (BOM)\n"); s += 2; + utf16be: if (PL_bufend > (char *)s) { U8 *news; I32 newlen; filter_add(utf16_textfilter, NULL); New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8); - PL_bufend = (char*)utf16_to_utf8(s, news, - PL_bufend - (char*)s, - &newlen); - Copy(news, s, newlen, U8); - SvCUR_set(PL_linestr, newlen); - PL_bufend = SvPVX(PL_linestr) + newlen; - news[newlen++] = '\0'; + PL_bufend = + (char*)utf16_to_utf8(s, news, + PL_bufend - (char*)s, + &newlen); + sv_setpvn(PL_linestr, (const char*)news, newlen); Safefree(news); + SvUTF8_on(PL_linestr); + s = (U8*)SvPVX(PL_linestr); + PL_bufend = SvPVX(PL_linestr) + newlen; } #else - Perl_croak(aTHX_ "Unsupported script encoding"); + Perl_croak(aTHX_ "Unsupported script encoding UTF16-BE"); #endif } break; case 0xEF: if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) { - DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n")); + if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-8 script encoding (BOM)\n"); s += 3; /* UTF-8 */ } break; case 0: - if (slen > 3 && s[1] == 0 && /* UTF-32 big-endian */ - s[2] == 0xFE && s[3] == 0xFF) - { - Perl_croak(aTHX_ "Unsupported script encoding"); + if (slen > 3) { + if (s[1] == 0) { + if (s[2] == 0xFE && s[3] == 0xFF) { + /* UTF-32 big-endian */ + Perl_croak(aTHX_ "Unsupported script encoding UTF32-BE"); + } + } + else if (s[2] == 0 && s[3] != 0) { + /* Leading bytes + * 00 xx 00 xx + * are a good indicator of UTF-16BE. */ + if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding (no BOM)\n"); + goto utf16be; + } } + default: + if (slen > 3 && s[1] == 0 && s[2] != 0 && s[3] == 0) { + /* Leading bytes + * xx 00 xx 00 + * are a good indicator of UTF-16LE. */ + if (DEBUG_p_TEST || DEBUG_T_TEST) PerlIO_printf(Perl_debug_log, "UTF-16LE script encoding (no BOM)\n"); + goto utf16le; + } } return (char*)s; } @@ -7817,3 +7992,89 @@ utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen) } #endif +/* +Returns a pointer to the next character after the parsed +vstring, as well as updating the passed in sv. + +Function must be called like + + sv = NEWSV(92,5); + s = scan_vstring(s,sv); + +The sv should already be large enough to store the vstring +passed in, for performance reasons. + +*/ + +char * +Perl_scan_vstring(pTHX_ char *s, SV *sv) +{ + char *pos = s; + char *start = s; + if (*pos == 'v') pos++; /* get past 'v' */ + while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_')) + pos++; + if ( *pos != '.') { + /* this may not be a v-string if followed by => */ + char *next = pos; + while (next < PL_bufend && isSPACE(*next)) + ++next; + if ((PL_bufend - next) >= 2 && *next == '=' && next[1] == '>' ) { + /* return string not v-string */ + sv_setpvn(sv,(char *)s,pos-s); + return pos; + } + } + + if (!isALPHA(*pos)) { + UV rev; + U8 tmpbuf[UTF8_MAXLEN+1]; + U8 *tmpend; + + if (*s == 'v') s++; /* get past 'v' */ + + sv_setpvn(sv, "", 0); + + for (;;) { + rev = 0; + { + /* this is atoi() that tolerates underscores */ + char *end = pos; + UV mult = 1; + while (--end >= s) { + UV orev; + if (*end == '_') + continue; + orev = rev; + rev += (*end - '0') * mult; + mult *= 10; + if (orev > rev && ckWARN_d(WARN_OVERFLOW)) + Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), + "Integer overflow in decimal number"); + } + } +#ifdef EBCDIC + if (rev > 0x7FFFFFFF) + Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647"); +#endif + /* Append native character for the rev point */ + tmpend = uvchr_to_utf8(tmpbuf, rev); + sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); + if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev))) + SvUTF8_on(sv); + if (pos + 1 < PL_bufend && *pos == '.' && isDIGIT(pos[1])) + s = ++pos; + else { + s = pos; + break; + } + while (pos < PL_bufend && (isDIGIT(*pos) || *pos == '_')) + pos++; + } + SvPOK_on(sv); + sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start); + SvRMAGICAL_on(sv); + } + return s; +} +