X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=737c9aef89c766dc8caaf7fde8675bccb44b9881;hb=b8bfa007e85f190696666dcd944c1c01b7860b92;hp=6107d77d19fbde005933c1b93cf23dcbe6c4aafe;hpb=44dcb63b0bb49fa80a224080c0601a2af7b94275;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index 6107d77..737c9ae 100644 --- a/toke.c +++ b/toke.c @@ -319,6 +319,7 @@ 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) { @@ -329,7 +330,6 @@ S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) 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; } @@ -344,10 +344,10 @@ S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen) 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 @@ -812,6 +812,31 @@ S_force_ident(pTHX_ register char *s, int kind) } } +NV +Perl_str_to_version(pTHX_ SV *sv) +{ + NV retval = 0.0; + NV nshift = 1.0; + STRLEN len; + char *start = SvPVx(sv,len); + bool utf = SvUTF8(sv); + char *end = start + len; + while (start < end) { + I32 skip; + UV n; + if (utf) + n = utf8_to_uv((U8*)start, &skip); + else { + n = *(U8*)start; + skip = 1; + } + retval += ((NV)n)/nshift; + start += skip; + nshift *= 1000; + } + return retval; +} + /* * S_force_version * Forces the next token to be a version number. @@ -821,26 +846,24 @@ STATIC char * S_force_version(pTHX_ char *s) { OP *version = Nullop; - bool is_vstr = FALSE; char *d; s = skipspace(s); d = s; - if (*d == 'v') { - is_vstr = TRUE; + if (*d == 'v') d++; - } if (isDIGIT(*d)) { for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++); if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) { + SV *ver; s = scan_num(s); - /* real VERSION number -- GBARR */ version = yylval.opval; - if (is_vstr) { - SV *ver = cSVOPx(version)->op_sv; - SvUPGRADE(ver, SVt_PVIV); - SvIOKp_on(ver); /* hint that it is a version */ + ver = cSVOPx(version)->op_sv; + if (SvPOK(ver) && !SvNIOK(ver)) { + (void)SvUPGRADE(ver, SVt_PVNV); + SvNVX(ver) = str_to_version(ver); + SvNOK_on(ver); /* hint that it is a version */ } } } @@ -1172,6 +1195,8 @@ S_scan_const(pTHX_ char *start) bool dorange = FALSE; /* are we in a translit range? */ bool has_utf = FALSE; /* embedded \x{} */ I32 len; /* ? */ + 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; @@ -1244,8 +1269,10 @@ S_scan_const(pTHX_ char *start) if (s[2] == '#') { while (s < send && *s != ')') *d++ = *s++; - } else if (s[2] == '{' - || s[2] == 'p' && s[3] == '{') { /* This should march regcomp.c */ + } + else if (s[2] == '{' /* This should match regcomp.c */ + || ((s[2] == 'p' || s[2] == '?') && s[3] == '{')) + { I32 count = 1; char *regparse = s + (s[2] == '{' ? 3 : 4); char c; @@ -1293,18 +1320,20 @@ S_scan_const(pTHX_ char *start) /* (now in tr/// code again) */ if (*s & 0x80 && thisutf) { - dTHR; /* only for ckWARN */ - if (ckWARN(WARN_UTF8)) { - (void)utf8_to_uv((U8*)s, &len); /* could cvt latin-1 to utf8 here... */ - if (len) { - has_utf = TRUE; - while (len--) - *d++ = *s++; - continue; - } - } - else - has_utf = TRUE; /* assume valid utf8 */ + (void)utf8_to_uv((U8*)s, &len); + if (len == 1) { + /* illegal UTF8, make it valid */ + char *old_pvx = SvPVX(sv); + /* need space for one extra char (NOTE: SvCUR() not set here) */ + d = SvGROW(sv, SvLEN(sv) + 1) + (d - old_pvx); + d = (char*)uv_to_utf8((U8*)d, (U8)*s++); + } + else { + while (len--) + *d++ = *s++; + } + has_utf = TRUE; + continue; } /* backslashes */ @@ -1360,51 +1389,75 @@ 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': - *d++ = (char)scan_oct(s, 3, &len); + uv = (UV)scan_oct(s, 3, &len); s += len; - continue; + goto NUM_ESCAPE_INSERT; /* \x24 indicates a hex constant */ case 'x': ++s; if (*s == '{') { char* e = strchr(s, '}'); - UV uv; - if (!e) { yyerror("Missing right brace on \\x{}"); e = s; } - /* note: utf always shorter than hex */ - uv = (UV)scan_hex(s + 1, e - s - 1, &len); - if (uv > 127) { - d = (char*)uv_to_utf8((U8*)d, uv); - has_utf = TRUE; - } - else - *d++ = (char)uv; - s = e + 1; + uv = (UV)scan_hex(s + 1, e - s - 1, &len); + s = e + 1; } else { - /* XXX collapse this branch into the one above */ - UV uv = (UV)scan_hex(s, 2, &len); - if (utf && PL_lex_inwhat == OP_TRANS && - utf != (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) - { - d = (char*)uv_to_utf8((U8*)d, uv); /* doing a CU or UC */ + uv = (UV)scan_hex(s, 2, &len); + s += len; + } + + NUM_ESCAPE_INSERT: + /* Insert oct or hex escaped character. + * 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) { + /* might need to recode whatever we have accumulated so far + * if it contains any hibit chars + */ + int hicount = 0; + char *c; + for (c = SvPVX(sv); c < d; c++) { + if (*c & 0x80) + hicount++; + } + if (hicount) { + char *old_pvx = SvPVX(sv); + char *src, *dst; + d = SvGROW(sv, SvCUR(sv) + hicount + 1) + (d - old_pvx); + + src = d - 1; + d += hicount; + dst = d - 1; + + while (src < dst) { + if (*src & 0x80) { + dst--; + uv_to_utf8((U8*)dst, (U8)*src--); + dst--; + } + else { + *dst-- = *src--; + } + } + } + } + + if (thisutf || uv > 255) { + d = (char*)uv_to_utf8((U8*)d, uv); has_utf = TRUE; - } + } else { - if (uv >= 127 && UTF) { - dTHR; - if (ckWARN(WARN_UTF8)) - Perl_warner(aTHX_ WARN_UTF8, - "\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that", - (int)len,s,(int)len,s); - } - *d++ = (char)uv; + *d++ = (char)uv; } - s += len; + } + else { + *d++ = (char)uv; } continue; @@ -1413,12 +1466,9 @@ S_scan_const(pTHX_ char *start) ++s; if (*s == '{') { char* e = strchr(s, '}'); - HV *hv; - SV **svp; - SV *res, *cv; + SV *res; STRLEN len; char *str; - char *why = Nullch; if (!e) { yyerror("Missing right brace on \\N{}"); @@ -1429,6 +1479,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); @@ -1452,7 +1510,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); @@ -2562,8 +2621,8 @@ Perl_yylex(pTHX) } d = moreswitches(d); } while (d); - if (PERLDB_LINE && !oldpdb || - ( PL_minus_n || PL_minus_p ) && !(oldn || oldp) ) + if ((PERLDB_LINE && !oldpdb) || + ((PL_minus_n || PL_minus_p) && !(oldn || oldp))) /* if we have already added "LINE: while (<>) {", we must not do it again */ { @@ -2589,7 +2648,7 @@ 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: s++; @@ -2597,6 +2656,11 @@ Perl_yylex(pTHX) 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++; @@ -3226,7 +3290,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); } @@ -3285,7 +3349,7 @@ Perl_yylex(pTHX) else if (isIDFIRST_lazy_if(s,UTF)) { char tmpbuf[sizeof PL_tokenbuf]; scan_word(s, tmpbuf, sizeof tmpbuf, TRUE, &len); - if (tmp = keyword(tmpbuf, len)) { + if ((tmp = keyword(tmpbuf, len))) { /* binary operators exclude handle interpretations */ switch (tmp) { case -KEY_x: @@ -3467,16 +3531,28 @@ Perl_yylex(pTHX) OPERATOR(REFGEN); case 'v': - if (isDIGIT(s[1]) && PL_expect == XTERM) { + if (isDIGIT(s[1]) && PL_expect != XOPERATOR) { char *start = s; start++; start++; - while (isDIGIT(*start)) + while (isDIGIT(*start) || *start == '_') start++; if (*start == '.' && isDIGIT(start[1])) { s = scan_num(s); TERM(THING); } + /* avoid v123abc() or $h{v1}, allow C */ + else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF)) { + char c = *start; + GV *gv; + *start = '\0'; + gv = gv_fetchpv(s, FALSE, SVt_PVCV); + *start = c; + if (!gv) { + s = scan_num(s); + TERM(THING); + } + } } goto keylookup; case 'x': @@ -3515,7 +3591,6 @@ Perl_yylex(pTHX) case 'z': case 'Z': keylookup: { - STRLEN n_a; gv = Nullgv; gvp = 0; @@ -3523,10 +3598,10 @@ Perl_yylex(pTHX) s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len); /* Some keywords can be followed by any delimiter, including ':' */ - tmp = (len == 1 && strchr("msyq", PL_tokenbuf[0]) || - len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') || - (PL_tokenbuf[0] == 'q' && - strchr("qwxr", PL_tokenbuf[1])))); + tmp = ((len == 1 && strchr("msyq", PL_tokenbuf[0])) || + (len == 2 && ((PL_tokenbuf[0] == 't' && PL_tokenbuf[1] == 'r') || + (PL_tokenbuf[0] == 'q' && + strchr("qwxr", PL_tokenbuf[1]))))); /* x::* is just a word, unless x is "CORE" */ if (!tmp && *s == ':' && s[1] == ':' && strNE(PL_tokenbuf, "CORE")) @@ -3549,7 +3624,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; @@ -3609,7 +3684,7 @@ Perl_yylex(pTHX) /* Get the rest if it looks like a package qualifier */ - if (*s == '\'' || *s == ':' && s[1] == ':') { + if (*s == '\'' || (*s == ':' && s[1] == ':')) { STRLEN morelen; s = scan_word(s, PL_tokenbuf + len, sizeof PL_tokenbuf - len, TRUE, &morelen); @@ -3704,10 +3779,18 @@ 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)) { @@ -3897,7 +3980,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; @@ -3923,7 +4007,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); @@ -4425,7 +4509,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) { @@ -5577,37 +5661,35 @@ S_checkcomma(pTHX_ register char *s, char *name, char *what) STATIC SV * S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, - const char *type) + const char *type) { dSP; HV *table = GvHV(PL_hintgv); /* ^H */ 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 */ @@ -5637,8 +5719,7 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv, SPAGAIN ; /* Check the eval first */ - if (!PL_in_eval && SvTRUE(ERRSV)) - { + if (!PL_in_eval && SvTRUE(ERRSV)) { STRLEN n_a; sv_catpv(ERRSV, "Propagated"); yyerror(SvPV(ERRSV, n_a)); /* Duplicates the message inside eval */ @@ -5656,14 +5737,14 @@ 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; - } + } - return res; + return res; } STATIC char * @@ -5790,7 +5871,7 @@ S_scan_ident(pTHX_ register char *s, register char *send, char *dest, STRLEN des d++; if (UTF) { e = s; - while (e < send && isALNUM_lazy_if(e,UTF) || *e == ':') { + while ((e < send && isALNUM_lazy_if(e,UTF)) || *e == ':') { e += UTF8SKIP(e); while (e < send && *e & 0x80 && is_utf8_mark((U8*)e)) e += UTF8SKIP(e); @@ -6621,7 +6702,6 @@ 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 */ - IV tryiv; /* used to see if it can be an IV */ NV value; /* number read, as a double */ SV *sv = Nullsv; /* place to put the converted number */ bool floatit; /* boolean: int or float? */ @@ -6846,6 +6926,11 @@ Perl_scan_num(pTHX_ char *start) if (*s != '_') *d++ = *s; } + if (*s == '.' && isDIGIT(s[1])) { + /* oops, it's really a v-string, but without the "v" */ + s = start - 1; + goto vstring; + } } /* read exponent part, if present */ @@ -6874,6 +6959,15 @@ Perl_scan_num(pTHX_ char *start) /* make an sv from the string */ sv = NEWSV(92,0); + /* unfortunately this monster needs to be on one line or + makedepend will be confused. */ +#if (defined(USE_64_BIT_INT) && (!defined(HAS_STRTOLL)|| !defined(HAS_STRTOULL))) || (!defined(USE_64_BIT_INT) && (!defined(HAS_STRTOL) || !defined(HAS_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); /* @@ -6886,25 +6980,60 @@ Perl_scan_num(pTHX_ char *start) Note: if floatit is true, then we don't need to do the conversion at all. */ - tryiv = I_V(value); - if (!floatit && (NV)tryiv == value) - sv_setiv(sv, tryiv); - else + { + UV 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) { + IV iv; + UV uv; + errno = 0; + if (*PL_tokenbuf == '-') + iv = Strtol(PL_tokenbuf, (char**)NULL, 10); + else + uv = Strtoul(PL_tokenbuf, (char**)NULL, 10); + if (errno) + floatit = TRUE; /* probably just too large */ + else if (*PL_tokenbuf == '-') + sv_setiv(sv, iv); + else + sv_setuv(sv, uv); + } + if (floatit) { + value = Atof(PL_tokenbuf); sv_setnv(sv, value); + } +#endif if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) sv = new_constant(PL_tokenbuf, d - PL_tokenbuf, (floatit ? "float" : "integer"), 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: { char *pos = s; pos++; - while (isDIGIT(*pos)) + while (isDIGIT(*pos) || *pos == '_') pos++; - if (*pos == '.' && isDIGIT(pos[1])) { + if (!isALPHA(*pos)) { UV rev; U8 tmpbuf[UTF8_MAXLEN]; U8 *tmpend; @@ -6914,32 +7043,38 @@ Perl_scan_num(pTHX_ char *start) sv = NEWSV(92,5); sv_setpvn(sv, "", 0); - do { + for (;;) { if (*s == '0' && isDIGIT(s[1])) yyerror("Octal number in vector unsupported"); - rev = atoi(s); - s = ++pos; - while (isDIGIT(*pos)) - pos++; - - if (rev > 127) { - tmpend = uv_to_utf8(tmpbuf, rev); - utf8 = TRUE; + 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_ WARN_OVERFLOW, + "Integer overflow in decimal number"); + } } + tmpend = uv_to_utf8(tmpbuf, rev); + utf8 = utf8 || rev > 127; + sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); + if (*pos == '.' && isDIGIT(pos[1])) + s = ++pos; else { - tmpbuf[0] = (U8)rev; - tmpend = &tmpbuf[1]; + s = pos; + break; } - sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); - } while (*pos == '.' && isDIGIT(pos[1])); - - if (*s == '0' && isDIGIT(s[1])) - yyerror("Octal number in vector unsupported"); - rev = atoi(s); - s = pos; - tmpend = uv_to_utf8(tmpbuf, rev); - utf8 = utf8 || rev > 127; - sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); + while (isDIGIT(*pos) || *pos == '_') + pos++; + } SvPOK_on(sv); SvREADONLY_on(sv); @@ -7187,8 +7322,14 @@ 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;