X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=b5e6b9caa21c8e357f93fe7dddb8acbb2aaa044b;hb=bbd5c0f5ad81733b079008f34cd05cd9aef7d917;hp=1095ae2113f11cb9b4874893d3b185c265801b3d;hpb=1143fce06f1e648f1e3622d992d89c012fd409c6;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index 1095ae2..b5e6b9c 100644 --- a/toke.c +++ b/toke.c @@ -27,23 +27,26 @@ static char ident_too_long[] = "Identifier too long"; -static void restore_rsfp(pTHXo_ void *f); +static void restore_rsfp(pTHX_ 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); +static I32 utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen); +static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen); #endif #define XFAKEBRACK 128 #define XENUMMASK 127 -#ifdef EBCDIC -/* For now 'use utf8' does not affect tokenizer on EBCDIC */ -#define UTF (PL_linestr && DO_UTF8(PL_linestr)) +#ifdef USE_UTF8_SCRIPTS +# define UTF (!IN_BYTES) #else -#define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8)) +# ifdef EBCDIC /* For now 'use utf8' does not affect tokenizer on EBCDIC */ +# define UTF (PL_linestr && DO_UTF8(PL_linestr)) +# else +# define UTF ((PL_linestr && DO_UTF8(PL_linestr)) || (PL_hints & HINT_UTF8)) +# endif #endif -/* In variables name $^X, these are the legal values for X. +/* In variables named $^X, these are the legal values for X. * 1999-02-27 mjd-perl-patch@plover.com */ #define isCONTROLVAR(x) (isUPPER(x) || strchr("[\\]^_?", (x))) @@ -181,12 +184,13 @@ int yyactlevel = -1; /* grandfather return to old style */ #define OLDLOP(f) return(yylval.ival=f,PL_expect = XTERM,PL_bufptr = s,(int)LSTOP) +#ifdef DEBUGGING + STATIC void S_tokereport(pTHX_ char *thing, char* s, I32 rv) { - SV *report; DEBUG_T({ - report = newSVpv(thing, 0); + SV* report = newSVpv(thing, 0); Perl_sv_catpvf(aTHX_ report, ":line %d:%"IVdf":", CopLINE(PL_curcop), (IV)rv); @@ -197,9 +201,11 @@ S_tokereport(pTHX_ char *thing, char* s, I32 rv) sv_catpv(report, PL_tokenbuf); } PerlIO_printf(Perl_debug_log, "### %s\n", SvPV_nolen(report)); - }) + }); } +#endif + /* * S_ao * @@ -439,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; } @@ -538,7 +542,7 @@ S_skipspace(pTHX_ register char *s) for (;;) { STRLEN prevlen; SSize_t oldprevlen, oldoldprevlen; - SSize_t oldloplen, oldunilen; + SSize_t oldloplen = 0, oldunilen = 0; while (s < PL_bufend && isSPACE(*s)) { if (*s++ == '\n' && PL_in_eval && !PL_rsfp) incline(s); @@ -630,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); } } @@ -858,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; @@ -872,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); @@ -884,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; } /* @@ -1043,6 +1055,7 @@ S_sublex_push(pTHX) SAVEI32(PL_lex_inwhat); SAVECOPLINE(PL_curcop); SAVEPPTR(PL_bufptr); + SAVEPPTR(PL_bufend); SAVEPPTR(PL_oldbufptr); SAVEPPTR(PL_oldoldbufptr); SAVEPPTR(PL_last_lop); @@ -1253,7 +1266,7 @@ S_scan_const(pTHX_ char *start) char *e = d++; while (e-- > c) *(e + 1) = *e; - *c = UTF_TO_NATIVE(0xff); + *c = (char)UTF_TO_NATIVE(0xff); /* mark the range as done, and continue */ dorange = FALSE; didrange = TRUE; @@ -1304,7 +1317,7 @@ S_scan_const(pTHX_ char *start) Perl_croak(aTHX_ "Ambiguous range in transliteration operator"); } if (has_utf8) { - *d++ = UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */ + *d++ = (char)UTF_TO_NATIVE(0xff); /* use illegal utf8 byte--see pmtrans */ s++; continue; } @@ -1370,7 +1383,7 @@ S_scan_const(pTHX_ char *start) else if (*s == '$') { if (!PL_lex_inpat) /* not a regexp, so $ must be var */ break; - if (s + 1 < send && !strchr("()| \n\t", s[1])) + if (s + 1 < send && !strchr("()| \r\n\t", s[1])) break; /* in regexp, $ might be tail anchor */ } @@ -1427,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; @@ -1438,20 +1452,24 @@ S_scan_const(pTHX_ char *start) ++s; if (*s == '{') { char* e = strchr(s, '}'); + I32 flags = PERL_SCAN_ALLOW_UNDERSCORES | + PERL_SCAN_DISALLOW_PREFIX; + STRLEN len; + + ++s; if (!e) { yyerror("Missing right brace on \\x{}"); - e = s; - } - else { - STRLEN len = 1; /* allow underscores */ - uv = (UV)scan_hex(s + 1, e - s - 1, &len); + continue; } + 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; } } @@ -1521,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 == '{') { @@ -1552,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))); @@ -1634,9 +1652,13 @@ S_scan_const(pTHX_ char *start) *d = '\0'; SvCUR_set(sv, d - SvPVX(sv)); if (SvCUR(sv) >= SvLEN(sv)) - Perl_croak(aTHX_ "panic:constant overflowed allocated space"); + 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) { @@ -2044,7 +2066,7 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) /* Call function. The function is expected to */ /* call "FILTER_READ(idx+1, buf_sv)" first. */ /* Return: <0:error, =0:eof, >0:not eof */ - return (*funcp)(aTHXo_ idx, buf_sv, maxlen); + return (*funcp)(aTHX_ idx, buf_sv, maxlen); } STATIC char * @@ -2162,132 +2184,8 @@ Perl_yylex(pTHX) bool bof = FALSE; /* check if there's an identifier for us to look at */ - if (PL_pending_ident) { - /* pit holds the identifier we read and pending_ident is reset */ - char pit = PL_pending_ident; - PL_pending_ident = 0; - - DEBUG_T({ PerlIO_printf(Perl_debug_log, - "### Tokener saw identifier '%s'\n", PL_tokenbuf); }) - - /* if we're in a my(), we can't allow dynamics here. - $foo'bar has already been turned into $foo::bar, so - just check for colons. - - if it's a legal name, the OP is a PADANY. - */ - if (PL_in_my) { - if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */ - if (strchr(PL_tokenbuf,':')) - yyerror(Perl_form(aTHX_ "No package name allowed for " - "variable %s in \"our\"", - PL_tokenbuf)); - tmp = pad_allocmy(PL_tokenbuf); - } - else { - if (strchr(PL_tokenbuf,':')) - yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf)); - - yylval.opval = newOP(OP_PADANY, 0); - yylval.opval->op_targ = pad_allocmy(PL_tokenbuf); - return PRIVATEREF; - } - } - - /* - build the ops for accesses to a my() variable. - - Deny my($a) or my($b) in a sort block, *if* $a or $b is - then used in a comparison. This catches most, but not - all cases. For instance, it catches - sort { my($a); $a <=> $b } - but not - sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; } - (although why you'd do that is anyone's guess). - */ - - if (!strchr(PL_tokenbuf,':')) { -#ifdef USE_THREADS - /* Check for single character per-thread SVs */ - if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0' - && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */ - && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD) - { - yylval.opval = newOP(OP_THREADSV, 0); - yylval.opval->op_targ = tmp; - return PRIVATEREF; - } -#endif /* USE_THREADS */ - if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) { - SV *namesv = AvARRAY(PL_comppad_name)[tmp]; - /* might be an "our" variable" */ - if (SvFLAGS(namesv) & SVpad_OUR) { - /* build ops for a bareword */ - SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0); - sv_catpvn(sym, "::", 2); - sv_catpv(sym, PL_tokenbuf+1); - yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym); - yylval.opval->op_private = OPpCONST_ENTERED; - gv_fetchpv(SvPVX(sym), - (PL_in_eval - ? (GV_ADDMULTI | GV_ADDINEVAL) - : TRUE - ), - ((PL_tokenbuf[0] == '$') ? SVt_PV - : (PL_tokenbuf[0] == '@') ? SVt_PVAV - : SVt_PVHV)); - return WORD; - } - - /* if it's a sort block and they're naming $a or $b */ - if (PL_last_lop_op == OP_SORT && - PL_tokenbuf[0] == '$' && - (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b') - && !PL_tokenbuf[2]) - { - for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart; - d < PL_bufend && *d != '\n'; - d++) - { - if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) { - Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison", - PL_tokenbuf); - } - } - } - - yylval.opval = newOP(OP_PADANY, 0); - yylval.opval->op_targ = tmp; - return PRIVATEREF; - } - } - - /* - Whine if they've said @foo in a doublequoted string, - and @foo isn't a variable we can find in the symbol - table. - */ - 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))) - && 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 */ - yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0)); - yylval.opval->op_private = OPpCONST_ENTERED; - gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE, - ((PL_tokenbuf[0] == '$') ? SVt_PV - : (PL_tokenbuf[0] == '@') ? SVt_PVAV - : SVt_PVHV)); - return WORD; - } + if (PL_pending_ident) + return S_pending_ident(aTHX); /* no identifier pending identification */ @@ -2309,7 +2207,7 @@ Perl_yylex(pTHX) } DEBUG_T({ PerlIO_printf(Perl_debug_log, "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr, - (IV)PL_nexttype[PL_nexttoke]); }) + (IV)PL_nexttype[PL_nexttoke]); }); return(PL_nexttype[PL_nexttoke]); @@ -2343,7 +2241,7 @@ Perl_yylex(pTHX) } else { DEBUG_T({ PerlIO_printf(Perl_debug_log, - "### Saw case modifier at '%s'\n", PL_bufptr); }) + "### Saw case modifier at '%s'\n", PL_bufptr); }); s = PL_bufptr + 1; if (strnEQ(s, "L\\u", 3) || strnEQ(s, "U\\l", 3)) tmp = *s, *s = s[2], s[2] = tmp; /* misordered... */ @@ -2395,20 +2293,20 @@ Perl_yylex(pTHX) if (PL_bufptr == PL_bufend) return sublex_done(); DEBUG_T({ PerlIO_printf(Perl_debug_log, - "### Interpolated variable at '%s'\n", PL_bufptr); }) + "### Interpolated variable at '%s'\n", PL_bufptr); }); PL_expect = XTERM; PL_lex_dojoin = (*PL_bufptr == '@'); PL_lex_state = LEX_INTERPNORMAL; if (PL_lex_dojoin) { PL_nextval[PL_nexttoke].ival = 0; force_next(','); -#ifdef USE_THREADS +#ifdef USE_5005THREADS PL_nextval[PL_nexttoke].opval = newOP(OP_THREADSV, 0); PL_nextval[PL_nexttoke].opval->op_targ = find_threadsv("\""); force_next(PRIVATEREF); #else force_ident("\"", '$'); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ PL_nextval[PL_nexttoke].ival = 0; force_next('$'); PL_nextval[PL_nexttoke].ival = 0; @@ -2495,7 +2393,7 @@ Perl_yylex(pTHX) DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at %s\n", exp_name[PL_expect], s); - } ) + } ); retry: switch (*s) { @@ -2514,7 +2412,7 @@ Perl_yylex(pTHX) yyerror("Missing right curly or square bracket"); DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Tokener got EOF\n"); - } ) + } ); TOKEN(0); } if (s++ < PL_bufend) @@ -2541,9 +2439,6 @@ Perl_yylex(pTHX) if (PL_minus_l) sv_catpv(PL_linestr,"chomp;"); if (PL_minus_a) { - GV* gv = gv_fetchpv("::F", TRUE, SVt_PVAV); - if (gv) - GvIMPORTED_AV_on(gv); if (PL_minus_F) { if (strchr("/'\"", *PL_splitstr) && strchr(PL_splitstr + 1, *PL_splitstr)) @@ -2553,7 +2448,7 @@ Perl_yylex(pTHX) s = "'~#\200\1'"; /* surely one char is unused...*/ while (s[1] && strchr(PL_splitstr, *s)) s++; delim = *s; - Perl_sv_catpvf(aTHX_ PL_linestr, "@F=split(%s%c", + Perl_sv_catpvf(aTHX_ PL_linestr, "our @F=split(%s%c", "q" + (delim == '\''), delim); for (s = PL_splitstr; *s; s++) { if (*s == '\\') @@ -2564,7 +2459,7 @@ Perl_yylex(pTHX) } } else - sv_catpv(PL_linestr,"@F=split(' ');"); + sv_catpv(PL_linestr,"our @F=split(' ');"); } } sv_catpv(PL_linestr, "\n"); @@ -2576,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; @@ -2659,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); @@ -2789,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; @@ -2812,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); + } } } } @@ -2847,6 +2755,8 @@ Perl_yylex(pTHX) s++; if (s < d) s++; + else if (s > d) /* Found by Ilya: feed random input to Perl. */ + Perl_croak(aTHX_ "panic: input overflow"); incline(s); if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) { PL_bufptr = s; @@ -2874,7 +2784,7 @@ Perl_yylex(pTHX) s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE); DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Saw unary minus before =>, forcing word '%s'\n", s); - } ) + } ); OPERATOR('-'); /* unary minus */ } PL_last_uni = PL_oldbufptr; @@ -2919,7 +2829,7 @@ Perl_yylex(pTHX) PL_last_lop_op = ftst; DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Saw file test %c\n", (int)ftst); - } ) + } ); FTST(ftst); } else { @@ -2928,7 +2838,7 @@ Perl_yylex(pTHX) DEBUG_T( { PerlIO_printf(Perl_debug_log, "### %c looked like a file test but was not\n", (int)ftst); - } ) + } ); s -= 2; } } @@ -3085,8 +2995,8 @@ Perl_yylex(pTHX) 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, "shared", len)) - GvSHARED_on(cGVOPx_gv(yylval.opval)); + 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 @@ -3225,8 +3135,16 @@ Perl_yylex(pTHX) else PL_lex_brackstack[PL_lex_brackets++] = XOPERATOR; s = skipspace(s); - if (*s == '}') + if (*s == '}') { + if (PL_expect == XREF && PL_lex_state == LEX_INTERPNORMAL) { + PL_expect = XTERM; + /* This hack is to get the ${} in the message. */ + PL_bufptr = s+1; + yyerror("syntax error"); + break; + } OPERATOR(HASHBRACK); + } /* This hack serves to disambiguate a pair of curlies * as being a block or an anon hash. Normally, expectation * determines that, but in cases where we're not in a @@ -3688,7 +3606,7 @@ Perl_yylex(pTHX) s = scan_num(s, &yylval); DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Saw number in '%s'\n", s); - } ) + } ); if (PL_expect == XOPERATOR) no_op("Number",s); TERM(THING); @@ -3697,7 +3615,7 @@ Perl_yylex(pTHX) s = scan_str(s,FALSE,FALSE); DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Saw string before '%s'\n", s); - } ) + } ); if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; @@ -3716,7 +3634,7 @@ Perl_yylex(pTHX) s = scan_str(s,FALSE,FALSE); DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Saw string before '%s'\n", s); - } ) + } ); if (PL_expect == XOPERATOR) { if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) { PL_expect = XTERM; @@ -3741,7 +3659,7 @@ Perl_yylex(pTHX) s = scan_str(s,FALSE,FALSE); DEBUG_T( { PerlIO_printf(Perl_debug_log, "### Saw backtick string before '%s'\n", s); - } ) + } ); if (PL_expect == XOPERATOR) no_op("Backticks",s); if (!s) @@ -3771,7 +3689,7 @@ Perl_yylex(pTHX) TERM(THING); } /* avoid v123abc() or $h{v1}, allow C */ - else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF)) { + else if (!isALPHA(*start) && (PL_expect == XTERM || PL_expect == XREF || PL_expect == XSTATE)) { char c = *start; GV *gv; *start = '\0'; @@ -3857,7 +3775,7 @@ Perl_yylex(pTHX) CLINE; yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0)); yylval.opval->op_private = OPpCONST_BARE; - if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, len)) + if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len)) SvUTF8_on(((SVOP*)yylval.opval)->op_sv); TERM(WORD); } @@ -3911,6 +3829,7 @@ Perl_yylex(pTHX) default: /* not a keyword */ just_a_word: { SV *sv; + int pkgname = 0; char lastchar = (PL_bufptr == PL_oldoldbufptr ? 0 : PL_bufptr[-1]); /* Get the rest if it looks like a package qualifier */ @@ -3923,6 +3842,7 @@ Perl_yylex(pTHX) Perl_croak(aTHX_ "Bad name after %s%s", PL_tokenbuf, *s == '\'' ? "'" : "::"); len += morelen; + pkgname = 1; } if (PL_expect == XOPERATOR) { @@ -4010,15 +3930,14 @@ Perl_yylex(pTHX) } } - PL_expect = XOPERATOR; s = skipspace(s); /* Is this a word before a => operator? */ - if (*s == '=' && s[1] == '>') { + if (*s == '=' && s[1] == '>' && !pkgname) { CLINE; sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf); - if (UTF && !IN_BYTE && is_utf8_string((U8*)PL_tokenbuf, len)) + if (UTF && !IN_BYTES && is_utf8_string((U8*)PL_tokenbuf, len)) SvUTF8_on(((SVOP*)yylval.opval)->op_sv); TERM(WORD); } @@ -4105,7 +4024,7 @@ Perl_yylex(pTHX) if (ckWARN(WARN_RESERVED)) { if (lastchar != '-') { for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ; - if (!*d) + if (!*d && strNE(PL_tokenbuf,"main")) Perl_warner(aTHX_ WARN_RESERVED, PL_warn_reserved, PL_tokenbuf); } @@ -4181,7 +4100,11 @@ Perl_yylex(pTHX) loc = PerlIO_tell(PL_rsfp); (void)PerlIO_seek(PL_rsfp, 0L, 0); } +#ifdef NETWARE + if (PerlLIO_setmode(PL_rsfp, O_TEXT) != -1) { +#else if (PerlLIO_setmode(PerlIO_fileno(PL_rsfp), O_TEXT) != -1) { +#endif /* NETWARE */ #ifdef PERLIO_IS_STDIO /* really? */ # if defined(__BORLANDC__) /* XXX see note in do_binmode() */ @@ -4194,7 +4117,7 @@ Perl_yylex(pTHX) } #endif #ifdef PERLIO_LAYERS - if (UTF && !IN_BYTE) + if (UTF && !IN_BYTES) PerlIO_apply_layers(aTHX_ PL_rsfp, NULL, ":utf8"); #endif PL_rsfp = Nullfp; @@ -4283,12 +4206,6 @@ Perl_yylex(pTHX) LOP(OP_CRYPT,XTERM); case KEY_chmod: - if (ckWARN(WARN_CHMOD)) { - for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ; - if (*d != '0' && isDIGIT(*d)) - Perl_warner(aTHX_ WARN_CHMOD, - "chmod() mode argument is missing initial 0"); - } LOP(OP_CHMOD,XTERM); case KEY_chown: @@ -4311,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: @@ -4641,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); @@ -4793,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)) @@ -4983,7 +4902,7 @@ Perl_yylex(pTHX) really_sub: { char tmpbuf[sizeof PL_tokenbuf]; - SSize_t tboffset; + SSize_t tboffset = 0; expectation attrful; bool have_name, have_proto; int key = tmp; @@ -5146,12 +5065,6 @@ Perl_yylex(pTHX) LOP(OP_UTIME,XTERM); case KEY_umask: - if (ckWARN(WARN_UMASK)) { - for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ; - if (*d != '0' && isDIGIT(*d)) - Perl_warner(aTHX_ WARN_UMASK, - "umask: argument is missing initial 0"); - } UNI(OP_UMASK); case KEY_unshift: @@ -5162,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); @@ -5201,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 @@ -5232,6 +5148,137 @@ Perl_yylex(pTHX) #pragma segment Main #endif +static int +S_pending_ident(pTHX) +{ + register char *d; + register I32 tmp; + /* pit holds the identifier we read and pending_ident is reset */ + char pit = PL_pending_ident; + PL_pending_ident = 0; + + DEBUG_T({ PerlIO_printf(Perl_debug_log, + "### Tokener saw identifier '%s'\n", PL_tokenbuf); }); + + /* if we're in a my(), we can't allow dynamics here. + $foo'bar has already been turned into $foo::bar, so + just check for colons. + + if it's a legal name, the OP is a PADANY. + */ + if (PL_in_my) { + if (PL_in_my == KEY_our) { /* "our" is merely analogous to "my" */ + if (strchr(PL_tokenbuf,':')) + yyerror(Perl_form(aTHX_ "No package name allowed for " + "variable %s in \"our\"", + PL_tokenbuf)); + tmp = pad_allocmy(PL_tokenbuf); + } + else { + if (strchr(PL_tokenbuf,':')) + yyerror(Perl_form(aTHX_ PL_no_myglob,PL_tokenbuf)); + + yylval.opval = newOP(OP_PADANY, 0); + yylval.opval->op_targ = pad_allocmy(PL_tokenbuf); + return PRIVATEREF; + } + } + + /* + build the ops for accesses to a my() variable. + + Deny my($a) or my($b) in a sort block, *if* $a or $b is + then used in a comparison. This catches most, but not + all cases. For instance, it catches + sort { my($a); $a <=> $b } + but not + sort { my($a); $a < $b ? -1 : $a == $b ? 0 : 1; } + (although why you'd do that is anyone's guess). + */ + + if (!strchr(PL_tokenbuf,':')) { +#ifdef USE_5005THREADS + /* Check for single character per-thread SVs */ + if (PL_tokenbuf[0] == '$' && PL_tokenbuf[2] == '\0' + && !isALPHA(PL_tokenbuf[1]) /* Rule out obvious non-threadsvs */ + && (tmp = find_threadsv(&PL_tokenbuf[1])) != NOT_IN_PAD) + { + yylval.opval = newOP(OP_THREADSV, 0); + yylval.opval->op_targ = tmp; + return PRIVATEREF; + } +#endif /* USE_5005THREADS */ + if ((tmp = pad_findmy(PL_tokenbuf)) != NOT_IN_PAD) { + SV *namesv = AvARRAY(PL_comppad_name)[tmp]; + /* might be an "our" variable" */ + if (SvFLAGS(namesv) & SVpad_OUR) { + /* build ops for a bareword */ + SV *sym = newSVpv(HvNAME(GvSTASH(namesv)),0); + sv_catpvn(sym, "::", 2); + sv_catpv(sym, PL_tokenbuf+1); + yylval.opval = (OP*)newSVOP(OP_CONST, 0, sym); + yylval.opval->op_private = OPpCONST_ENTERED; + gv_fetchpv(SvPVX(sym), + (PL_in_eval + ? (GV_ADDMULTI | GV_ADDINEVAL) + : TRUE + ), + ((PL_tokenbuf[0] == '$') ? SVt_PV + : (PL_tokenbuf[0] == '@') ? SVt_PVAV + : SVt_PVHV)); + return WORD; + } + + /* if it's a sort block and they're naming $a or $b */ + if (PL_last_lop_op == OP_SORT && + PL_tokenbuf[0] == '$' && + (PL_tokenbuf[1] == 'a' || PL_tokenbuf[1] == 'b') + && !PL_tokenbuf[2]) + { + for (d = PL_in_eval ? PL_oldoldbufptr : PL_linestart; + d < PL_bufend && *d != '\n'; + d++) + { + if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) { + Perl_croak(aTHX_ "Can't use \"my %s\" in sort comparison", + PL_tokenbuf); + } + } + } + + yylval.opval = newOP(OP_PADANY, 0); + yylval.opval->op_targ = tmp; + return PRIVATEREF; + } + } + + /* + Whine if they've said @foo in a doublequoted string, + and @foo isn't a variable we can find in the symbol + table. + */ + 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))) + && 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 */ + yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf+1, 0)); + yylval.opval->op_private = OPpCONST_ENTERED; + gv_fetchpv(PL_tokenbuf+1, PL_in_eval ? (GV_ADDMULTI | GV_ADDINEVAL) : TRUE, + ((PL_tokenbuf[0] == '$') ? SVt_PV + : (PL_tokenbuf[0] == '@') ? SVt_PVAV + : SVt_PVHV)); + return WORD; +} + I32 Perl_keyword(pTHX_ register char *d, I32 len) { @@ -5627,7 +5674,7 @@ Perl_keyword(pTHX_ register char *d, I32 len) if (strEQ(d,"rindex")) return -KEY_rindex; break; case 7: - if (strEQ(d,"require")) return -KEY_require; + if (strEQ(d,"require")) return KEY_require; if (strEQ(d,"reverse")) return -KEY_reverse; if (strEQ(d,"readdir")) return -KEY_readdir; break; @@ -6501,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)) { @@ -6522,7 +6571,7 @@ retval: Renew(SvPVX(tmpstr), SvLEN(tmpstr), char); } SvREFCNT_dec(herewas); - if (UTF && !IN_BYTE && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr))) + if (UTF && !IN_BYTES && is_utf8_string((U8*)SvPVX(tmpstr), SvCUR(tmpstr))) SvUTF8_on(tmpstr); PL_lex_stuff = tmpstr; yylval.ival = op_type; @@ -6617,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))); @@ -6834,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); } @@ -6876,11 +6944,11 @@ S_scan_str(pTHX_ char *start, int keep_quoted, int keep_delims) Read a number in any of the formats that Perl accepts: - 0(x[0-7A-F]+)|([0-7]+)|(b[01]) - [\d_]+(\.[\d_]*)?[Ee](\d+) - - Underbars (_) are allowed in decimal numbers. If -w is on, - underbars before a decimal point must be at three digit intervals. + \d(_?\d)*(\.(\d(_?\d)*)?)?[Ee][\+\-]?(\d(_?\d)*) 12 12.34 12. + \.\d(_?\d)*[Ee][\+\-]?(\d(_?\d)*) .34 + 0b[01](_?[01])* + 0[0-7](_?[0-7])* + 0x[0-9A-Fa-f](_?[0-9A-Fa-f])* Like most scan_ routines, it uses the PL_tokenbuf buffer to hold the thing it reads. @@ -6950,8 +7018,17 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) else if (s[1] == '.' || s[1] == 'e' || s[1] == 'E') goto decimal; /* so it must be octal */ - else + else { shift = 3; + s++; + } + + if (*s == '_') { + if (ckWARN(WARN_SYNTAX)) + Perl_warner(aTHX_ WARN_SYNTAX, + "Misplaced _ in number"); + lastub = s++; + } base = bases[shift]; Base = Bases[shift]; @@ -6969,9 +7046,12 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) default: goto out; - /* _ are ignored */ + /* _ are ignored -- but warned about if consecutive */ case '_': - s++; + if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1) + Perl_warner(aTHX_ WARN_SYNTAX, + "Misplaced _ in number"); + lastub = s++; break; /* 8 and 9 are not octal */ @@ -7038,6 +7118,13 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) the number. */ out: + + /* final misplaced underbar check */ + if (s[-1] == '_') { + if (ckWARN(WARN_SYNTAX)) + Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number"); + } + sv = NEWSV(92,0); if (overflowed) { if (ckWARN(WARN_PORTABLE) && n > 4294967295.0) @@ -7077,9 +7164,10 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) if -w is on */ if (*s == '_') { - if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3) - Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number"); - lastub = ++s; + if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1) + Perl_warner(aTHX_ WARN_SYNTAX, + "Misplaced _ in number"); + lastub = s++; } else { /* check for end of fixed-length buffer */ @@ -7091,7 +7179,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) } /* final misplaced underbar check */ - if (lastub && s - lastub != 3) { + if (lastub && s == lastub + 1) { if (ckWARN(WARN_SYNTAX)) Perl_warner(aTHX_ WARN_SYNTAX, "Misplaced _ in number"); } @@ -7104,16 +7192,34 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) floatit = TRUE; *d++ = *s++; - /* copy, ignoring underbars, until we run out of - digits. Note: no misplaced underbar checks! + if (*s == '_') { + if (ckWARN(WARN_SYNTAX)) + Perl_warner(aTHX_ WARN_SYNTAX, + "Misplaced _ in number"); + lastub = s; + } + + /* copy, ignoring underbars, until we run out of digits. */ for (; isDIGIT(*s) || *s == '_'; s++) { /* fixed length buffer check */ if (d >= e) Perl_croak(aTHX_ number_too_long); - if (*s != '_') + if (*s == '_') { + if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1) + Perl_warner(aTHX_ WARN_SYNTAX, + "Misplaced _ in number"); + lastub = s; + } + else *d++ = *s; } + /* fractional part ending in underbar? */ + if (s[-1] == '_') { + if (ckWARN(WARN_SYNTAX)) + Perl_warner(aTHX_ WARN_SYNTAX, + "Misplaced _ in number"); + } if (*s == '.' && isDIGIT(s[1])) { /* oops, it's really a v-string, but without the "v" */ s = start - 1; @@ -7122,110 +7228,84 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) } /* read exponent part, if present */ - if (*s && strchr("eE",*s) && strchr("+-0123456789",s[1])) { + if (*s && strchr("eE",*s) && strchr("+-0123456789_", s[1])) { floatit = TRUE; s++; /* regardless of whether user said 3E5 or 3e5, use lower 'e' */ *d++ = 'e'; /* At least some Mach atof()s don't grok 'E' */ + /* stray preinitial _ */ + if (*s == '_') { + if (ckWARN(WARN_SYNTAX)) + Perl_warner(aTHX_ WARN_SYNTAX, + "Misplaced _ in number"); + lastub = s++; + } + /* allow positive or negative exponent */ if (*s == '+' || *s == '-') *d++ = *s++; - /* read digits of exponent (no underbars :-) */ - while (isDIGIT(*s)) { - if (d >= e) - Perl_croak(aTHX_ number_too_long); - *d++ = *s++; + /* stray initial _ */ + if (*s == '_') { + if (ckWARN(WARN_SYNTAX)) + Perl_warner(aTHX_ WARN_SYNTAX, + "Misplaced _ in number"); + lastub = s++; + } + + /* read digits of exponent */ + while (isDIGIT(*s) || *s == '_') { + if (isDIGIT(*s)) { + if (d >= e) + Perl_croak(aTHX_ number_too_long); + *d++ = *s++; + } + else { + if (ckWARN(WARN_SYNTAX) && + ((lastub && s == lastub + 1) || + (!isDIGIT(s[1]) && s[1] != '_'))) + Perl_warner(aTHX_ WARN_SYNTAX, + "Misplaced _ in number"); + lastub = s++; + } } } - /* terminate the string */ - *d = '\0'; /* make an sv from the string */ sv = NEWSV(92,0); -#if defined(Strtol) && defined(Strtoul) - /* - 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. + 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 if (uv <= IV_MAX) + int flags = grok_number (PL_tokenbuf, d - PL_tokenbuf, &uv); + + if (flags == IS_NUMBER_IN_UV) { + if (uv <= IV_MAX) sv_setiv(sv, uv); /* Prefer IVs over UVs. */ - else + else sv_setuv(sv, uv); - } + } else if (flags == (IS_NUMBER_IN_UV | IS_NUMBER_NEG)) { + if (uv <= (UV) IV_MIN) + sv_setiv(sv, -(IV)uv); + else + floatit = TRUE; + } else + floatit = TRUE; + } if (floatit) { + /* terminate the string */ + *d = '\0'; nv = Atof(PL_tokenbuf); sv_setnv(sv, nv); } -#else - /* - 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, nv); - } -#endif if ( floatit ? (PL_hints & HINT_NEW_FLOAT) : (PL_hints & HINT_NEW_INTEGER) ) sv = new_constant(PL_tokenbuf, d - PL_tokenbuf, @@ -7336,15 +7416,19 @@ S_scan_formline(pTHX_ register char *s) if (*t == '@' || *t == '^') needargs = TRUE; } - sv_catpvn(stuff, s, eol-s); + if (eol > s) { + sv_catpvn(stuff, s, eol-s); #ifndef PERL_STRICT_CR - if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') { - char *end = SvPVX(stuff) + SvCUR(stuff); - end[-2] = '\n'; - end[-1] = '\0'; - SvCUR(stuff)--; - } + if (eol-s > 1 && eol[-2] == '\r' && eol[-1] == '\n') { + char *end = SvPVX(stuff) + SvCUR(stuff); + end[-2] = '\n'; + end[-1] = '\0'; + SvCUR(stuff)--; + } #endif + } + else + break; } s = eol; if (PL_rsfp) { @@ -7425,11 +7509,11 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) PL_min_intro_pending = 0; PL_padix = 0; PL_subline = CopLINE(PL_curcop); -#ifdef USE_THREADS +#ifdef USE_5005THREADS av_store(PL_comppad_name, 0, newSVpvn("@_", 2)); PL_curpad[0] = (SV*)newAV(); SvPADMY_on(PL_curpad[0]); /* XXX Needed? */ -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ comppadlist = newAV(); AvREAL_off(comppadlist); @@ -7438,11 +7522,11 @@ Perl_start_subparse(pTHX_ I32 is_format, U32 flags) CvPADLIST(PL_compcv) = comppadlist; CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(outsidecv); -#ifdef USE_THREADS +#ifdef USE_5005THREADS CvOWNER(PL_compcv) = 0; New(666, CvMUTEXP(PL_compcv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(PL_compcv)); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ return oldsavestack_ix; } @@ -7617,17 +7701,13 @@ S_swallow_bom(pTHX_ U8 *s) return (char*)s; } -#ifdef PERL_OBJECT -#include "XSUB.h" -#endif - /* * restore_rsfp * Restore a source filter. */ static void -restore_rsfp(pTHXo_ void *f) +restore_rsfp(pTHX_ void *f) { PerlIO *fp = (PerlIO*)f; @@ -7640,7 +7720,7 @@ restore_rsfp(pTHXo_ void *f) #ifndef PERL_NO_UTF16_FILTER static I32 -utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen) +utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen) { I32 count = FILTER_READ(idx+1, sv, maxlen); if (count) { @@ -7659,7 +7739,7 @@ utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen) } static I32 -utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen) +utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen) { I32 count = FILTER_READ(idx+1, sv, maxlen); if (count) { @@ -7677,3 +7757,4 @@ utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen) return count; } #endif +