X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=627468cb7fb8f513cf1642718b322fed8dc18df6;hb=35d904946636411814f392bec019cad90a357c0a;hp=2527e95edaa92addb524b686fda7e321847222d6;hpb=b35112e751727d4207068fd54bf0c9d77ad0ba97;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index 2527e95..627468c 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, by Larry Wall and others + * 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. @@ -256,18 +256,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; } @@ -786,6 +791,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; @@ -1322,7 +1329,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 */ @@ -1341,10 +1348,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++); } @@ -2184,6 +2189,11 @@ Perl_yylex_r(pTHX_ YYSTYPE *lvalp, int *lcharp) Perl_croak(aTHX_ "panic: YYMAXLEVEL"); r = Perl_yylex(aTHX); +# ifdef EBCDIC + if (r >= 0 && r < 255) { + r = NATIVE_TO_ASCII(r); + } +# endif if (yyactlevel > 0) yyactlevel--; @@ -2427,8 +2437,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"); } ); @@ -2875,10 +2889,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++; @@ -3026,9 +3040,20 @@ 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); @@ -3036,11 +3061,6 @@ Perl_yylex(pTHX) CvMETHOD_on(PL_compcv); else if (!PL_in_my && len == 9 && strnEQ(s, "assertion", len)) CvASSERTION_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 /* 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 @@ -3557,9 +3577,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)) @@ -5524,7 +5542,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; @@ -6507,7 +6527,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); @@ -6996,7 +7017,7 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) goto read_more_line; else { /* handle quoted delimiters */ - if (*(svlast-1) == '\\') { + if (SvCUR(sv) > 1 && *(svlast-1) == '\\') { char *t; for (t = svlast-2; t >= SvPVX(sv) && *t == '\\';) t--; @@ -7252,6 +7273,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" }; @@ -7268,9 +7290,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') @@ -7342,6 +7366,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) */ digit: + just_zero = FALSE; if (!overflowed) { x = u << shift; /* make room for the digit */ @@ -7400,7 +7425,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; @@ -7596,20 +7624,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; } @@ -7646,7 +7677,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; } } @@ -7675,7 +7705,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; @@ -7808,8 +7839,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) { @@ -7984,10 +8015,10 @@ Perl_scan_vstring(pTHX_ char *s, SV *sv) pos++; if ( *pos != '.') { /* this may not be a v-string if followed by => */ - start = pos; - while (start < PL_bufend && isSPACE(*start)) - ++start; - if ((PL_bufend - start) >= 2 && *start == '=' && start[1] == '>' ) { + 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;