X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=314753f5848fa508bc216db8e1d6732c482c3bea;hb=ad8caead208db46a636808a4d2bb49d677c061a4;hp=1ebd17b62e34c057747258ddf21c4b7c3fb5beca;hpb=9bbb1adaf4f03189507dea28ff5773b762523248;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index 1ebd17b..314753f 100644 --- a/toke.c +++ b/toke.c @@ -445,8 +445,6 @@ Perl_lex_start(pTHX_ SV *line) PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = SvPVX(PL_linestr); PL_bufend = PL_bufptr + SvCUR(PL_linestr); PL_last_lop = PL_last_uni = Nullch; - SvREFCNT_dec(PL_rs); - PL_rs = newSVpvn("\n", 1); PL_rsfp = 0; } @@ -636,6 +634,8 @@ S_skipspace(pTHX_ register char *s) sv_upgrade(sv, SVt_PVMG); sv_setpvn(sv,PL_bufptr,PL_bufend-PL_bufptr); + (void)SvIOK_on(sv); + SvIVX(sv) = 0; av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); } } @@ -864,10 +864,13 @@ Perl_str_to_version(pTHX_ SV *sv) /* * S_force_version * Forces the next token to be a version number. + * If the next token appears to be an invalid version number, (e.g. "v2b"), + * and if "guessing" is TRUE, then no new token is created (and the caller + * must use an alternative parsing method). */ STATIC char * -S_force_version(pTHX_ char *s) +S_force_version(pTHX_ char *s, int guessing) { OP *version = Nullop; char *d; @@ -878,7 +881,8 @@ S_force_version(pTHX_ char *s) if (*d == 'v') d++; if (isDIGIT(*d)) { - for (; isDIGIT(*d) || *d == '_' || *d == '.'; d++); + while (isDIGIT(*d) || *d == '_' || *d == '.') + d++; if (*d == ';' || isSPACE(*d) || *d == '}' || !*d) { SV *ver; s = scan_num(s, &yylval); @@ -890,13 +894,15 @@ S_force_version(pTHX_ char *s) SvNOK_on(ver); /* hint that it is a version */ } } + else if (guessing) + return s; } /* NOTE: The parser sees the package name and the VERSION swapped */ PL_nextval[PL_nexttoke].opval = version; force_next(WORD); - return (s); + return s; } /* @@ -1434,8 +1440,9 @@ S_scan_const(pTHX_ char *start) case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': { - STRLEN len = 0; /* disallow underscores */ - uv = (UV)scan_oct(s, 3, &len); + I32 flags = 0; + STRLEN len = 3; + uv = grok_oct(s, &len, &flags, NULL); s += len; } goto NUM_ESCAPE_INSERT; @@ -1445,20 +1452,24 @@ S_scan_const(pTHX_ char *start) ++s; if (*s == '{') { char* e = strchr(s, '}'); - STRLEN len = 1; /* allow underscores */ + I32 flags = PERL_SCAN_ALLOW_UNDERSCORES | + PERL_SCAN_DISALLOW_PREFIX; + STRLEN len; + ++s; if (!e) { yyerror("Missing right brace on \\x{}"); - ++s; continue; } - uv = (UV)scan_hex(s + 1, e - s - 1, &len); + len = e - s; + uv = grok_hex(s, &len, &flags, NULL); s = e + 1; } else { { - STRLEN len = 0; /* disallow underscores */ - uv = (UV)scan_hex(s, 2, &len); + STRLEN len = 2; + I32 flags = PERL_SCAN_DISALLOW_PREFIX; + uv = grok_hex(s, &len, &flags, NULL); s += len; } } @@ -1528,7 +1539,7 @@ S_scan_const(pTHX_ char *start) } continue; - /* \N{latin small letter a} is a named character */ + /* \N{LATIN SMALL LETTER A} is a named character */ case 'N': ++s; if (*s == '{') { @@ -1559,7 +1570,7 @@ S_scan_const(pTHX_ char *start) d = SvPVX(sv) + SvCUR(sv); has_utf8 = TRUE; } - if (len > e - s + 4) { + if (len > e - s + 4) { /* I _guess_ 4 is \N{} --jhi */ char *odest = SvPVX(sv); SvGROW(sv, (SvLEN(sv) + len - (e - s + 4))); @@ -1644,6 +1655,10 @@ S_scan_const(pTHX_ char *start) Perl_croak(aTHX_ "panic: constant overflowed allocated space"); SvPOK_on(sv); + if (PL_encoding && !has_utf8) { + Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding); + has_utf8 = TRUE; + } if (has_utf8) { SvUTF8_on(sv); if (PL_lex_inwhat == OP_TRANS && PL_sublex_info.sub_op) { @@ -1965,7 +1980,7 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) 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))); + (void*)funcp, SvPV_nolen(datasv))); av_unshift(PL_rsfp_filters, 1); av_store(PL_rsfp_filters, 0, datasv) ; return(datasv); @@ -1977,7 +1992,7 @@ void Perl_filter_del(pTHX_ filter_t funcp) { SV *datasv; - DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", funcp)); + DEBUG_P(PerlIO_printf(Perl_debug_log, "filter_del func %p", (void*)funcp)); if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0) return; /* if filter is on top of stack (usual case) just pop it off */ @@ -2047,7 +2062,7 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) 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))); + idx, (void*)funcp, SvPV_nolen(datasv))); /* Call function. The function is expected to */ /* call "FILTER_READ(idx+1, buf_sv)" first. */ /* Return: <0:error, =0:eof, >0:not eof */ @@ -2427,7 +2442,7 @@ Perl_yylex(pTHX) if (PL_minus_F) { if (strchr("/'\"", *PL_splitstr) && strchr(PL_splitstr + 1, *PL_splitstr)) - Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s);", PL_splitstr); + Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s);", PL_splitstr); else { char delim; s = "'~#\200\1'"; /* surely one char is unused...*/ @@ -2456,6 +2471,8 @@ Perl_yylex(pTHX) sv_upgrade(sv, SVt_PVMG); sv_setsv(sv,PL_linestr); + (void)SvIOK_on(sv); + SvIVX(sv) = 0; av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); } goto retry; @@ -2539,6 +2556,8 @@ Perl_yylex(pTHX) sv_upgrade(sv, SVt_PVMG); sv_setsv(sv,PL_linestr); + (void)SvIOK_on(sv); + SvIVX(sv) = 0; av_store(CopFILEAV(PL_curcop),(I32)CopLINE(PL_curcop),sv); } PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr); @@ -2579,7 +2598,7 @@ Perl_yylex(pTHX) * at least, set argv[0] to the basename of the Perl * interpreter. So, having found "#!", we'll set it right. */ - SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); + SV *x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */ assert(SvPOK(x) || SvGMAGICAL(x)); if (sv_eq(x, CopFILESV(PL_curcop))) { sv_setpvn(x, ipath, ipathend - ipath); @@ -2669,6 +2688,7 @@ Perl_yylex(pTHX) while (SPACE_OR_TAB(*d)) d++; if (*d++ == '-') { + bool switches_done = PL_doswitches; do { if (*d == 'M' || *d == 'm') { char *m = d; @@ -2692,6 +2712,14 @@ Perl_yylex(pTHX) (void)gv_fetchfile(PL_origfilename); goto retry; } + 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); + } } } } @@ -4200,7 +4228,7 @@ Perl_yylex(pTHX) if (*s == '{') PRETERMBLOCK(DO); if (*s != '\'') - s = force_word(s,WORD,FALSE,TRUE,FALSE); + s = force_word(s,WORD,TRUE,TRUE,FALSE); OPERATOR(DO); case KEY_die: @@ -4530,7 +4558,7 @@ Perl_yylex(pTHX) if (PL_expect != XSTATE) yyerror("\"no\" not allowed in expression"); s = force_word(s,WORD,FALSE,TRUE,FALSE); - s = force_version(s); + s = force_version(s, FALSE); yylval.ival = 0; OPERATOR(USE); @@ -4682,10 +4710,12 @@ Perl_yylex(pTHX) case KEY_require: s = skipspace(s); - if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { - s = force_version(s); + if (isDIGIT(*s)) { + s = force_version(s, FALSE); } - else { + else if (*s != 'v' || !isDIGIT(s[1]) + || (s = force_version(s, TRUE), *s == 'v')) + { *PL_tokenbuf = '\0'; s = force_word(s,WORD,TRUE,TRUE,FALSE); if (isIDFIRST_lazy_if(PL_tokenbuf,UTF)) @@ -5045,15 +5075,19 @@ Perl_yylex(pTHX) yyerror("\"use\" not allowed in expression"); s = skipspace(s); if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) { - s = force_version(s); + s = force_version(s, TRUE); if (*s == ';' || (s = skipspace(s), *s == ';')) { PL_nextval[PL_nexttoke].opval = Nullop; force_next(WORD); } + else if (*s == 'v') { + s = force_word(s,WORD,FALSE,TRUE,FALSE); + s = force_version(s, FALSE); + } } else { s = force_word(s,WORD,FALSE,TRUE,FALSE); - s = force_version(s); + s = force_version(s, FALSE); } yylval.ival = 1; OPERATOR(USE); @@ -5084,10 +5118,9 @@ Perl_yylex(pTHX) case KEY_write: #ifdef EBCDIC { - static char ctl_l[2]; - - if (ctl_l[0] == '\0') - ctl_l[0] = toCTRL('L'); + char ctl_l[2]; + ctl_l[0] = toCTRL('L'); + ctl_l[1] = '\0'; gv_fetchpv(ctl_l,TRUE, SVt_PV); } #else @@ -5297,12 +5330,12 @@ Perl_keyword(pTHX_ register char *d, I32 len) if (strEQ(d,"cos")) return -KEY_cos; break; case 4: - if (strEQ(d,"chop")) return -KEY_chop; + if (strEQ(d,"chop")) return KEY_chop; break; case 5: if (strEQ(d,"close")) return -KEY_close; if (strEQ(d,"chdir")) return -KEY_chdir; - if (strEQ(d,"chomp")) return -KEY_chomp; + if (strEQ(d,"chomp")) return KEY_chomp; if (strEQ(d,"chmod")) return -KEY_chmod; if (strEQ(d,"chown")) return -KEY_chown; if (strEQ(d,"crypt")) return -KEY_crypt; @@ -6515,6 +6548,8 @@ S_scan_heredoc(pTHX_ register char *s) sv_upgrade(sv, SVt_PVMG); sv_setsv(sv,PL_linestr); + (void)SvIOK_on(sv); + SvIVX(sv) = 0; av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop),sv); } if (*s == term && memEQ(s,PL_tokenbuf,len)) { @@ -6631,12 +6666,29 @@ S_scan_inputsymbol(pTHX_ char *start) add symbol table ops */ if ((tmp = pad_findmy(d)) != NOT_IN_PAD) { - OP *o = newOP(OP_PADSV, 0); - o->op_targ = tmp; - PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o); + SV *namesv = AvARRAY(PL_comppad_name)[tmp]; + if (SvFLAGS(namesv) & SVpad_OUR) { + SV *sym = sv_2mortal(newSVpv(HvNAME(GvSTASH(namesv)),0)); + sv_catpvn(sym, "::", 2); + sv_catpv(sym, d+1); + d = SvPVX(sym); + goto intro_sym; + } + else { + OP *o = newOP(OP_PADSV, 0); + o->op_targ = tmp; + PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o); + } } else { - GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV); + GV *gv; + ++d; +intro_sym: + gv = gv_fetchpv(d, + (PL_in_eval + ? (GV_ADDMULTI | GV_ADDINEVAL) + : TRUE), + SVt_PV); PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv))); @@ -6848,6 +6900,8 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) sv_upgrade(sv, SVt_PVMG); sv_setsv(sv,PL_linestr); + (void)SvIOK_on(sv); + SvIVX(sv) = 0; av_store(CopFILEAV(PL_curcop), (I32)CopLINE(PL_curcop), sv); } @@ -7168,7 +7222,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) } if (*s == '.' && isDIGIT(s[1])) { /* oops, it's really a v-string, but without the "v" */ - s = start - 1; + s = start; goto vstring; } } @@ -7262,58 +7316,8 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) /* if it starts with a v, it could be a v-string */ case 'v': vstring: - { - char *pos = s; - pos++; - while (isDIGIT(*pos) || *pos == '_') - pos++; - if (!isALPHA(*pos)) { - UV rev; - U8 tmpbuf[UTF8_MAXLEN+1]; - U8 *tmpend; - s++; /* get past 'v' */ - - sv = NEWSV(92,5); - sv_setpvn(sv, "", 0); - - for (;;) { - if (*s == '0' && isDIGIT(s[1])) - yyerror("Octal number in vector unsupported"); - 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"); - } - } - /* 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 == '.' && isDIGIT(pos[1])) - s = ++pos; - else { - s = pos; - break; - } - while (isDIGIT(*pos) || *pos == '_') - pos++; - } - SvPOK_on(sv); - SvREADONLY_on(sv); - } - } + sv = NEWSV(92,5); /* preallocate storage space */ + s = new_vstring(s,sv); break; } @@ -7703,3 +7707,4 @@ utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen) return count; } #endif +