X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=777719f727a2d475f1ec55dbd0ee623752403599;hb=298e5f695df9e9b8ba9d8ecad678734c47cd6d78;hp=a6010162b3498c0d61e1ebce70919f5358dd8272;hpb=f69763b06909a72bacc3730622752f9777f5cbc1;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index a601016..777719f 100644 --- a/toke.c +++ b/toke.c @@ -28,6 +28,10 @@ static char ident_too_long[] = "Identifier too long"; static void restore_rsfp(pTHXo_ void *f); +#ifndef PERL_NO_UTF16_FILTER +static I32 utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen); +static I32 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen); +#endif #define XFAKEBRACK 128 #define XENUMMASK 127 @@ -39,6 +43,13 @@ static void restore_rsfp(pTHXo_ void *f); * 1999-02-27 mjd-perl-patch@plover.com */ #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x))) +/* On MacOS, respect nonbreaking spaces */ +#ifdef MACOS_TRADITIONAL +#define SPACE_OR_TAB(c) ((c)==' '||(c)=='\312'||(c)=='\t') +#else +#define SPACE_OR_TAB(c) ((c)==' '||(c)=='\t') +#endif + /* LEX_* are values for PL_lex_state, the state of the lexer. * They are arranged oddly so that the guard on the switch statement * can get by with a single comparison (if the compiler is smart enough). @@ -319,36 +330,6 @@ S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen) } #endif -#if 0 -STATIC I32 -S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) -{ - I32 count = FILTER_READ(idx+1, sv, maxlen); - if (count) { - U8* tmps; - U8* tend; - New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8); - tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv)); - sv_usepvn(sv, (char*)tmps, tend - tmps); - } - return count; -} - -STATIC I32 -S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen) -{ - I32 count = FILTER_READ(idx+1, sv, maxlen); - if (count) { - U8* tmps; - U8* tend; - New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8); - tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv)); - sv_usepvn(sv, (char*)tmps, tend - tmps); - } - return count; -} -#endif - /* * Perl_lex_start * Initialize variables. Uses the Perl save_stack to save its state (for @@ -463,7 +444,7 @@ S_incline(pTHX_ char *s) CopLINE_inc(PL_curcop); if (*s++ != '#') return; - while (*s == ' ' || *s == '\t') s++; + while (SPACE_OR_TAB(*s)) s++; if (strnEQ(s, "line", 4)) s += 4; else @@ -472,13 +453,13 @@ S_incline(pTHX_ char *s) s++; else return; - while (*s == ' ' || *s == '\t') s++; + while (SPACE_OR_TAB(*s)) s++; if (!isDIGIT(*s)) return; n = s; while (isDIGIT(*s)) s++; - while (*s == ' ' || *s == '\t') + while (SPACE_OR_TAB(*s)) s++; if (*s == '"' && (t = strchr(s+1, '"'))) { s++; @@ -488,15 +469,21 @@ S_incline(pTHX_ char *s) for (t = s; !isSPACE(*t); t++) ; e = t; } - while (*e == ' ' || *e == '\t' || *e == '\r' || *e == '\f') + while (SPACE_OR_TAB(*e) || *e == '\r' || *e == '\f') e++; if (*e != '\n' && *e != '\0') return; /* false alarm */ ch = *t; *t = '\0'; - if (t - s > 0) + if (t - s > 0) { +#ifdef USE_ITHREADS + Safefree(CopFILE(PL_curcop)); +#else + SvREFCNT_dec(CopFILEGV(PL_curcop)); +#endif CopFILE_set(PL_curcop, s); + } *t = ch; CopLINE_set(PL_curcop, atoi(n)-1); } @@ -512,7 +499,7 @@ S_skipspace(pTHX_ register char *s) { dTHR; if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { - while (s < PL_bufend && (*s == ' ' || *s == '\t')) + while (s < PL_bufend && SPACE_OR_TAB(*s)) s++; return s; } @@ -819,7 +806,7 @@ Perl_str_to_version(pTHX_ SV *sv) NV nshift = 1.0; STRLEN len; char *start = SvPVx(sv,len); - bool utf = SvUTF8(sv); + bool utf = SvUTF8(sv) ? TRUE : FALSE; char *end = start + len; while (start < end) { I32 skip; @@ -896,7 +883,7 @@ S_tokeq(pTHX_ SV *sv) goto finish; s = SvPV_force(sv, len); - if (SvIVX(sv) == -1) + if (SvTYPE(sv) >= SVt_PVIV && SvIVX(sv) == -1) goto finish; send = s + len; while (s < send && *s != '\\') @@ -974,6 +961,8 @@ S_sublex_start(pTHX) p = SvPV(sv, len); nsv = newSVpvn(p, len); + if (SvUTF8(sv)) + SvUTF8_on(nsv); SvREFCNT_dec(sv); sv = nsv; } @@ -1193,6 +1182,7 @@ S_scan_const(pTHX_ char *start) register char *s = start; /* start of the constant */ 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{} */ I32 len; /* ? */ UV uv; @@ -1226,6 +1216,12 @@ S_scan_const(pTHX_ char *start) min = (U8)*d; /* first char in range */ max = (U8)d[1]; /* last char in range */ + if (min > max) { + Perl_croak(aTHX_ + "Invalid [] range \"%c-%c\" in transliteration operator", + min, max); + } + #ifndef ASCIIish if ((isLOWER(min) && isLOWER(max)) || (isUPPER(min) && isUPPER(max))) { @@ -1246,11 +1242,15 @@ S_scan_const(pTHX_ char *start) /* mark the range as done, and continue */ dorange = FALSE; + didrange = TRUE; continue; - } + } /* range begins (ignore - as first or last char) */ else if (*s == '-' && s+1 < send && s != start) { + if (didrange) { + Perl_croak(aTHX_ "Ambiguous range in transliteration operator"); + } if (utf) { *d++ = (char)0xff; /* use illegal utf8 byte--see pmtrans */ s++; @@ -1259,6 +1259,9 @@ S_scan_const(pTHX_ char *start) dorange = TRUE; s++; } + else { + didrange = FALSE; + } } /* if we get here, we're not doing a transliteration */ @@ -1377,7 +1380,7 @@ S_scan_const(pTHX_ char *start) default: { dTHR; - if (ckWARN(WARN_MISC) && isALPHA(*s)) + if (ckWARN(WARN_MISC) && isALNUM(*s)) Perl_warner(aTHX_ WARN_MISC, "Unrecognized escape \\%c passed through", *s); @@ -1389,6 +1392,7 @@ S_scan_const(pTHX_ char *start) /* \132 indicates an octal constant */ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': + len = 0; /* disallow underscores */ uv = (UV)scan_oct(s, 3, &len); s += len; goto NUM_ESCAPE_INSERT; @@ -1402,10 +1406,12 @@ S_scan_const(pTHX_ char *start) yyerror("Missing right brace on \\x{}"); e = s; } + len = 1; /* allow underscores */ uv = (UV)scan_hex(s + 1, e - s - 1, &len); s = e + 1; } else { + len = 0; /* disallow underscores */ uv = (UV)scan_hex(s, 2, &len); s += len; } @@ -1479,6 +1485,14 @@ S_scan_const(pTHX_ char *start) res = new_constant( Nullch, 0, "charnames", res, Nullsv, "\\N{...}" ); str = SvPV(res,len); + if (!has_utf && SvUTF8(res)) { + char *ostart = SvPVX(sv); + SvCUR_set(sv, d - ostart); + SvPOK_on(sv); + sv_utf8_upgrade(sv); + d = SvPVX(sv) + SvCUR(sv); + has_utf = TRUE; + } if (len > e - s + 4) { char *odest = SvPVX(sv); @@ -1502,7 +1516,8 @@ S_scan_const(pTHX_ char *start) *d = *s++; if (isLOWER(*d)) *d = toUPPER(*d); - *d++ = toCTRL(*d); + *d = toCTRL(*d); + d++; #else len = *s++; *d++ = toCTRL(len); @@ -1848,7 +1863,7 @@ S_incl_perldb(pTHX) * store private buffers and state information. * * The supplied datasv parameter is upgraded to a PVIO type - * and the IoDIRP field is used to store the function pointer, + * and the IoDIRP/IoANY field is used to store the function pointer, * and IOf_FAKE_DIRP is enabled on datasv to mark this as such. * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for * private use must be set using malloc'd pointers. @@ -1866,7 +1881,7 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) datasv = NEWSV(255,0); if (!SvUPGRADE(datasv, SVt_PVIO)) Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO"); - IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */ + IoANY(datasv) = (void *)funcp; /* stash funcp into spare field */ IoFLAGS(datasv) |= IOf_FAKE_DIRP; DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_add func %p (%s)\n", funcp, SvPV_nolen(datasv))); @@ -1886,9 +1901,9 @@ Perl_filter_del(pTHX_ filter_t funcp) return; /* if filter is on top of stack (usual case) just pop it off */ datasv = FILTER_DATA(AvFILLp(PL_rsfp_filters)); - if (IoDIRP(datasv) == (DIR*)funcp) { + if (IoANY(datasv) == (void *)funcp) { IoFLAGS(datasv) &= ~IOf_FAKE_DIRP; - IoDIRP(datasv) = (DIR*)NULL; + IoANY(datasv) = (void *)NULL; sv_free(av_pop(PL_rsfp_filters)); return; @@ -1948,7 +1963,7 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */ } /* Get function pointer hidden within datasv */ - funcp = (filter_t)IoDIRP(datasv); + funcp = (filter_t)IoANY(datasv); DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_read %d: via function %p (%s)\n", idx, funcp, SvPV_nolen(datasv))); @@ -1979,6 +1994,31 @@ S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append) return (sv_gets(sv, fp, append)); } +STATIC HV * +S_find_in_my_stash(pTHX_ char *pkgname, I32 len) +{ + GV *gv; + + if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__")) + return PL_curstash; + + if (len > 2 && + (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') && + (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV))) + { + return GvHV(gv); /* Foo:: */ + } + + /* use constant CLASS => 'MyClass' */ + if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) { + SV *sv; + if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) { + pkgname = SvPV_nolen(sv); + } + } + + return gv_stashpv(pkgname, FALSE); +} #ifdef DEBUGGING static char* exp_name[] = @@ -2012,6 +2052,9 @@ S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append) if we already built the token before, use it. */ +#ifdef __SC__ +#pragma segment Perl_yylex +#endif int #ifdef USE_PURE_BISON Perl_yylex(pTHX_ YYSTYPE *lvalp, int *lcharp) @@ -2137,9 +2180,14 @@ Perl_yylex(pTHX) */ if (pit == '@' && PL_lex_state != LEX_NORMAL && !PL_lex_brackets) { GV *gv = gv_fetchpv(PL_tokenbuf+1, FALSE, SVt_PVAV); - if (!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv))) - yyerror(Perl_form(aTHX_ "In string, %s now must be written as \\%s", - PL_tokenbuf, PL_tokenbuf)); + if ((!gv || ((PL_tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv))) + && ckWARN(WARN_AMBIGUOUS)) + { + /* Downgraded from fatal to warning 20000522 mjd */ + Perl_warner(aTHX_ WARN_AMBIGUOUS, + "Possible unintended interpolation of %s in string", + PL_tokenbuf); + } } /* build ops for a bareword */ @@ -2432,7 +2480,10 @@ Perl_yylex(pTHX) goto retry; } do { - if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) { + bool bof; + bof = PL_rsfp && (PerlIO_tell(PL_rsfp) == 0); /* *Before* read! */ + s = filter_gets(PL_linestr, PL_rsfp, 0); + if (s == Nullch) { fake_eof: if (PL_rsfp) { if (PL_preprocess && !PL_in_eval) @@ -2455,6 +2506,9 @@ Perl_yylex(pTHX) PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr); sv_setpv(PL_linestr,""); TOKEN(';'); /* not infinite loop because rsfp is NULL now */ + } else if (bof) { + PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); + s = swallow_bom((U8*)s); } if (PL_doextract) { if (*s == '#' && s[1] == '!' && instr(s,"perl")) @@ -2467,7 +2521,7 @@ Perl_yylex(pTHX) 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; @@ -2567,6 +2621,7 @@ Perl_yylex(pTHX) *s = '#'; /* Don't try to parse shebang line */ } #endif /* ALTERNATE_SHEBANG */ +#ifndef MACOS_TRADITIONAL if (!d && *s == '#' && ipathend > ipath && @@ -2594,13 +2649,14 @@ Perl_yylex(pTHX) PerlProc_execv(ipath, newargv); Perl_croak(aTHX_ "Can't exec %s", ipath); } +#endif if (d) { U32 oldpdb = PL_perldb; bool oldn = PL_minus_n; bool oldp = PL_minus_p; while (*d && !isSPACE(*d)) d++; - while (*d == ' ' || *d == '\t') d++; + while (SPACE_OR_TAB(*d)) d++; if (*d++ == '-') { do { @@ -2639,14 +2695,22 @@ Perl_yylex(pTHX) #ifdef PERL_STRICT_CR Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r'); Perl_croak(aTHX_ - "(Maybe you didn't strip carriage returns after a network transfer?)\n"); + "\t(Maybe you didn't strip carriage returns after a network transfer?)\n"); #endif case ' ': case '\t': case '\f': case 013: +#ifdef MACOS_TRADITIONAL + case '\312': +#endif s++; goto retry; case '#': case '\n': if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) { + if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) { + /* handle eval qq[#line 1 "foo"\n ...] */ + CopLINE_dec(PL_curcop); + incline(s); + } d = PL_bufend; while (s < d && *s != '\n') s++; @@ -2670,7 +2734,7 @@ Perl_yylex(pTHX) PL_bufptr = s; tmp = *s++; - while (s < PL_bufend && (*s == ' ' || *s == '\t')) + while (s < PL_bufend && SPACE_OR_TAB(*s)) s++; if (strnEQ(s,"=>",2)) { @@ -2909,8 +2973,7 @@ Perl_yylex(pTHX) PL_expect = XTERM; TOKEN('('); case ';': - if (CopLINE(PL_curcop) < PL_copline) - PL_copline = CopLINE(PL_curcop); + CLINE; tmp = *s++; OPERATOR(tmp); case ')': @@ -2954,20 +3017,20 @@ Perl_yylex(pTHX) PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; OPERATOR(HASHBRACK); case XOPERATOR: - while (s < PL_bufend && (*s == ' ' || *s == '\t')) + while (s < PL_bufend && SPACE_OR_TAB(*s)) s++; d = s; PL_tokenbuf[0] = '\0'; if (d < PL_bufend && *d == '-') { PL_tokenbuf[0] = '-'; d++; - while (d < PL_bufend && (*d == ' ' || *d == '\t')) + while (d < PL_bufend && SPACE_OR_TAB(*d)) d++; } if (d < PL_bufend && isIDFIRST_lazy_if(d,UTF)) { d = scan_word(d, PL_tokenbuf + 1, sizeof PL_tokenbuf - 1, FALSE, &len); - while (d < PL_bufend && (*d == ' ' || *d == '\t')) + while (d < PL_bufend && SPACE_OR_TAB(*d)) d++; if (*d == '}') { char minus = (PL_tokenbuf[0] == '-'); @@ -3087,7 +3150,7 @@ Perl_yylex(pTHX) yyerror("Unmatched right curly bracket"); else PL_expect = (expectation)PL_lex_brackstack[--PL_lex_brackets]; - if (PL_lex_brackets < PL_lex_formbrack) + if (PL_lex_brackets < PL_lex_formbrack && PL_lex_state != LEX_INTERPNORMAL) PL_lex_formbrack = 0; if (PL_lex_state == LEX_INTERPNORMAL) { if (PL_lex_brackets == 0) { @@ -3184,9 +3247,9 @@ Perl_yylex(pTHX) if (PL_lex_brackets < PL_lex_formbrack) { char *t; #ifdef PERL_STRICT_CR - for (t = s; *t == ' ' || *t == '\t'; t++) ; + for (t = s; SPACE_OR_TAB(*t); t++) ; #else - for (t = s; *t == ' ' || *t == '\t' || *t == '\r'; t++) ; + for (t = s; SPACE_OR_TAB(*t) || *t == '\r'; t++) ; #endif if (*t == '\n' || *t == '#') { s--; @@ -3276,7 +3339,7 @@ Perl_yylex(pTHX) /* This kludge not intended to be bulletproof. */ if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) { yylval.opval = newSVOP(OP_CONST, 0, - newSViv((IV)PL_compiling.cop_arybase)); + newSViv(PL_compiling.cop_arybase)); yylval.opval->op_private = OPpCONST_ARYBASE; TERM(THING); } @@ -3610,7 +3673,7 @@ Perl_yylex(pTHX) tmp = keyword(PL_tokenbuf, len); /* Is this a word before a => operator? */ - if (strnEQ(d,"=>",2)) { + if (*d == '=' && d[1] == '>') { CLINE; yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0)); yylval.opval->op_private = OPpCONST_BARE; @@ -3765,14 +3828,22 @@ Perl_yylex(pTHX) } } - /* If followed by a paren, it's certainly a subroutine. */ PL_expect = XOPERATOR; s = skipspace(s); + + /* Is this a word before a => operator? */ + if (*s == '=' && s[1] == '>') { + CLINE; + sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf); + TERM(WORD); + } + + /* If followed by a paren, it's certainly a subroutine. */ if (*s == '(') { CLINE; if (gv && GvCVu(gv)) { - for (d = s + 1; *d == ' ' || *d == '\t'; d++) ; + for (d = s + 1; SPACE_OR_TAB(*d); d++) ; if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) { s = d + 1; goto its_constant; @@ -3958,7 +4029,8 @@ Perl_yylex(pTHX) s += 2; d = s; s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); - tmp = keyword(PL_tokenbuf, len); + if (!(tmp = keyword(PL_tokenbuf, len))) + Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf); if (tmp < 0) tmp = -tmp; goto reserved_word; @@ -3984,7 +4056,7 @@ Perl_yylex(pTHX) LOP(OP_BIND,XTERM); case KEY_binmode: - UNI(OP_BINMODE); + LOP(OP_BINMODE,XTERM); case KEY_bless: LOP(OP_BLESS,XTERM); @@ -4357,7 +4429,7 @@ Perl_yylex(pTHX) s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len); if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3)) goto really_sub; - PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE); + PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len); if (!PL_in_my_stash) { char tmpbuf[1024]; PL_bufptr = s; @@ -4486,7 +4558,7 @@ Perl_yylex(pTHX) for (; !isSPACE(*d) && len; --len, ++d) ; } words = append_elem(OP_LIST, words, - newSVOP(OP_CONST, 0, newSVpvn(b, d-b))); + newSVOP(OP_CONST, 0, tokeq(newSVpvn(b, d-b)))); } } if (words) { @@ -4965,6 +5037,9 @@ Perl_yylex(pTHX) } }} } +#ifdef __SC__ +#pragma segment Main +#endif I32 Perl_keyword(pTHX_ register char *d, I32 len) @@ -5067,7 +5142,6 @@ Perl_keyword(pTHX_ register char *d, I32 len) } break; case 'E': - if (strEQ(d,"EQ")) { deprecate(d); return -KEY_eq;} if (strEQ(d,"END")) return KEY_END; break; case 'e': @@ -5133,12 +5207,6 @@ Perl_keyword(pTHX_ register char *d, I32 len) break; } break; - case 'G': - if (len == 2) { - if (strEQ(d,"GT")) { deprecate(d); return -KEY_gt;} - if (strEQ(d,"GE")) { deprecate(d); return -KEY_ge;} - } - break; case 'g': if (strnEQ(d,"get",3)) { d += 3; @@ -5238,12 +5306,6 @@ Perl_keyword(pTHX_ register char *d, I32 len) if (strEQ(d,"kill")) return -KEY_kill; } break; - case 'L': - if (len == 2) { - if (strEQ(d,"LT")) { deprecate(d); return -KEY_lt;} - if (strEQ(d,"LE")) { deprecate(d); return -KEY_le;} - } - break; case 'l': switch (len) { case 2: @@ -5295,9 +5357,6 @@ Perl_keyword(pTHX_ register char *d, I32 len) break; } break; - case 'N': - if (strEQ(d,"NE")) { deprecate(d); return -KEY_ne;} - break; case 'n': if (strEQ(d,"next")) return KEY_next; if (strEQ(d,"ne")) return -KEY_ne; @@ -5645,30 +5704,28 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, SV *res; SV **cvp; SV *cv, *typesv; - const char *why, *why1, *why2; + const char *why1, *why2, *why3; - if (!(PL_hints & HINT_LOCALIZE_HH)) { + if (!table || !(PL_hints & HINT_LOCALIZE_HH)) { SV *msg; - why = "%^H is not localized"; - report_short: - why1 = why2 = ""; + why1 = "%^H is not consistent"; + why2 = strEQ(key,"charnames") + ? " (missing \"use charnames ...\"?)" + : ""; + why3 = ""; report: msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s", - (type ? type: "undef"), why1, why2, why); + (type ? type: "undef"), why1, why2, why3); yyerror(SvPVX(msg)); SvREFCNT_dec(msg); return sv; } - if (!table) { - why = "%^H is not defined"; - goto report_short; - } cvp = hv_fetch(table, key, strlen(key), FALSE); if (!cvp || !SvOK(*cvp)) { - why = "} is not defined"; why1 = "$^H{"; why2 = key; + why3 = "} is not defined"; goto report; } sv_2mortal(sv); /* Parent created it permanently */ @@ -5716,9 +5773,9 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, POPSTACK; if (!SvOK(res)) { - why = "}} did not return a defined value"; why1 = "Call to &{$^H{"; why2 = key; + why3 = "}} did not return a defined value"; sv = res; goto report; } @@ -5840,7 +5897,7 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des if (isSPACE(s[-1])) { while (s < send) { char ch = *s++; - if (ch != ' ' && ch != '\t') { + if (!SPACE_OR_TAB(ch)) { *d = ch; break; } @@ -5866,7 +5923,7 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des Perl_croak(aTHX_ ident_too_long); } *d = '\0'; - while (s < send && (*s == ' ' || *s == '\t')) s++; + 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)) { @@ -6076,45 +6133,20 @@ S_scan_trans(pTHX_ char *start) Perl_croak(aTHX_ "Transliteration replacement not terminated"); } - if (UTF) { - o = newSVOP(OP_TRANS, 0, 0); - utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF; - } - else { - New(803,tbl,256,short); - o = newPVOP(OP_TRANS, 0, (char*)tbl); - utf8 = 0; - } + New(803,tbl,256,short); + o = newPVOP(OP_TRANS, 0, (char*)tbl); complement = del = squash = 0; - while (strchr("cdsCU", *s)) { + while (strchr("cds", *s)) { if (*s == 'c') complement = OPpTRANS_COMPLEMENT; else if (*s == 'd') del = OPpTRANS_DELETE; else if (*s == 's') squash = OPpTRANS_SQUASH; - else { - switch (count++) { - case 0: - if (*s == 'C') - utf8 &= ~OPpTRANS_FROM_UTF; - else - utf8 |= OPpTRANS_FROM_UTF; - break; - case 1: - if (*s == 'C') - utf8 &= ~OPpTRANS_TO_UTF; - else - utf8 |= OPpTRANS_TO_UTF; - break; - default: - Perl_croak(aTHX_ "Too many /C and /U options"); - } - } s++; } - o->op_private = del|squash|complement|utf8; + o->op_private = del|squash|complement; PL_lex_op = o; yylval.ival = OP_TRANS; @@ -6140,7 +6172,7 @@ S_scan_heredoc(pTHX_ register char *s) e = PL_tokenbuf + sizeof PL_tokenbuf - 1; if (!outer) *d++ = '\n'; - for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ; + for (peek = s; SPACE_OR_TAB(*peek); peek++) ; if (*peek && strchr("`'\"",*peek)) { s = peek; term = *s++; @@ -6681,8 +6713,7 @@ Perl_scan_num(pTHX_ char *start) register char *s = start; /* current position in buffer */ register char *d; /* destination in temp buffer */ register char *e; /* end of temp buffer */ - UV tryuv; /* used to see if it can be an UV */ - NV value; /* number read, as a double */ + NV nv; /* number read, as a double */ SV *sv = Nullsv; /* place to put the converted number */ bool floatit; /* boolean: int or float? */ char *lastub = 0; /* position of last underbar */ @@ -6939,80 +6970,84 @@ Perl_scan_num(pTHX_ char *start) /* make an sv from the string */ sv = NEWSV(92,0); -#if ( defined(USE_64_BIT_INT) && \ - (!defined(HAS_STRTOLL)|| !defined(HAS_STRTOULL))) || \ - (!defined(USE_64_BIT_INT) && \ - (!defined(HAS_STRTOL) || !defined(HAS_STRTOUL))) +#if defined(Strtol) && defined(Strtoul) /* - No working strto[u]l[l]. Since atoi() doesn't do range checks, - we need to do this the hard way. - */ - - value = Atof(PL_tokenbuf); - - /* - See if we can make do with an integer value without loss of - precision. We use I_V to cast to an int, because some - compilers have issues. Then we try casting it back and see - if it was the same. We only do this if we know we - specifically read an integer. - - Note: if floatit is true, then we don't need to do the - conversion at all. - */ - tryuv = U_V(value); - if (!floatit && (NV)tryuv == value) { - if (tryuv <= IV_MAX) - sv_setiv(sv, (IV)tryuv); - else - sv_setuv(sv, tryuv); - } - else - sv_setnv(sv, value); -#else - /* strtol/strtoll sets errno to ERANGE if the number is too big for an integer. We try to do an integer conversion first if no characters indicating "float" have been found. */ if (!floatit) { - char *tp; IV iv; UV uv; errno = 0; -#ifdef USE_64_BIT_INT - if (*PL_tokenbuf == '-') - iv = strtoll(PL_tokenbuf,&tp,10); - else - uv = strtoull(PL_tokenbuf,&tp,10); -#else if (*PL_tokenbuf == '-') - iv = strtol(PL_tokenbuf,&tp,10); + iv = Strtol(PL_tokenbuf, (char**)NULL, 10); else - uv = strtoul(PL_tokenbuf,&tp,10); -#endif - if (*tp || errno) - floatit = TRUE; /* probably just too large */ + uv = Strtoul(PL_tokenbuf, (char**)NULL, 10); + if (errno) + floatit = TRUE; /* Probably just too large. */ else if (*PL_tokenbuf == '-') sv_setiv(sv, iv); + else if (uv <= IV_MAX) + sv_setiv(sv, uv); /* Prefer IVs over UVs. */ else sv_setuv(sv, uv); } if (floatit) { - char *tp; - errno = 0; -#ifdef USE_LONG_DOUBLE - value = strtold(PL_tokenbuf,&tp); + nv = Atof(PL_tokenbuf); + sv_setnv(sv, nv); + } #else - value = strtod(PL_tokenbuf,&tp); -#endif - if (*tp || errno) - Perl_die(aTHX_ "unparseable float"); + /* + No working strtou?ll?. + + Unfortunately atol() doesn't do range checks (returning + LONG_MIN/LONG_MAX, and setting errno to ERANGE on overflows) + everywhere [1], so we cannot use use atol() (or atoll()). + If we could, they would be used, as Atol(), very much like + Strtol() and Strtoul() are used above. + + [1] XXX Configure test needed to check for atol() + (and atoll()) overflow behaviour XXX + + --jhi + + We need to do this the hard way. */ + + nv = Atof(PL_tokenbuf); + + /* See if we can make do with an integer value without loss of + precision. We use U_V to cast to a UV, because some + 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. + + [1] Note that this is lossy if our NVs cannot preserve our + UVs. There are metaconfig defines NV_PRESERVES_UV (a boolean) + and NV_PRESERVES_UV_BITS (a number), but in general we really + do hope all such potentially lossy platforms have strtou?ll? + to do a lossless IV/UV conversion. + + 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 + */ + { + UV uv = U_V(nv); + if (!floatit && (NV)uv == nv) { + if (uv <= IV_MAX) + sv_setiv(sv, uv); /* Prefer IVs over UVs. */ + else + sv_setuv(sv, uv); + } else - sv_setnv(sv, value); - } + sv_setnv(sv, nv); + } #endif if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) @@ -7021,7 +7056,7 @@ Perl_scan_num(pTHX_ char *start) sv, Nullsv, NULL); break; - /* if it starts with a v, it could be a version number */ + /* if it starts with a v, it could be a v-string */ case 'v': vstring: { @@ -7103,12 +7138,12 @@ S_scan_formline(pTHX_ register char *s) bool needargs = FALSE; while (!needargs) { - if (*s == '.' || *s == '}') { + if (*s == '.' || *s == /*{*/'}') { /*SUPPRESS 530*/ #ifdef PERL_STRICT_CR - for (t = s+1;*t == ' ' || *t == '\t'; t++) ; + for (t = s+1;SPACE_OR_TAB(*t); t++) ; #else - for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ; + for (t = s+1;SPACE_OR_TAB(*t) || *t == '\r'; t++) ; #endif if (*t == '\n' || t == PL_bufend) break; @@ -7318,13 +7353,93 @@ Perl_yyerror(pTHX_ char *s) Perl_warn(aTHX_ "%"SVf, msg); else qerror(msg); - if (PL_error_count >= 10) - Perl_croak(aTHX_ "%s has too many errors.\n", CopFILE(PL_curcop)); + if (PL_error_count >= 10) { + if (PL_in_eval && SvCUR(ERRSV)) + Perl_croak(aTHX_ "%_%s has too many errors.\n", + ERRSV, CopFILE(PL_curcop)); + else + Perl_croak(aTHX_ "%s has too many errors.\n", + CopFILE(PL_curcop)); + } PL_in_my = 0; PL_in_my_stash = Nullhv; return 0; } +STATIC char* +S_swallow_bom(pTHX_ U8 *s) +{ + STRLEN slen; + slen = SvCUR(PL_linestr); + switch (*s) { + 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"); +#ifndef PERL_NO_UTF16_FILTER + DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n")); + s += 2; + 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'; + Safefree(news); + } +#else + Perl_croak(aTHX_ "Unsupported script encoding"); +#endif + } + break; + case 0xFE: + 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")); + s += 2; + 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'; + Safefree(news); + } +#else + Perl_croak(aTHX_ "Unsupported script encoding"); +#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")); + 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"); + } + } + return (char*)s; +} #ifdef PERL_OBJECT #include "XSUB.h" @@ -7346,3 +7461,43 @@ restore_rsfp(pTHXo_ void *f) PerlIO_close(PL_rsfp); PL_rsfp = fp; } + +#ifndef PERL_NO_UTF16_FILTER +static I32 +utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen) +{ + I32 count = FILTER_READ(idx+1, sv, maxlen); + if (count) { + U8* tmps; + U8* tend; + I32 newlen; + New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8); + 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); + } + return count; +} + +static I32 +utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen) +{ + I32 count = FILTER_READ(idx+1, sv, maxlen); + if (count) { + U8* tmps; + U8* tend; + I32 newlen; + if (!*SvPV_nolen(sv)) + /* Game over, but don't feed an odd-length string to utf16_to_utf8 */ + return count; + + New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8); + tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen); + sv_usepvn(sv, (char*)tmps, tend - tmps); + } + return count; +} +#endif