X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/58bb9ec35570407378c221c05d56adab1a48b1e6..2a37f04dcbe9376a1280272d62501209825ac83c:/toke.c diff --git a/toke.c b/toke.c index 11b8a7b..a9a2821 100644 --- a/toke.c +++ b/toke.c @@ -1,6 +1,6 @@ /* toke.c * - * Copyright (c) 1991-2001, Larry Wall + * Copyright (c) 1991-2002, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -27,20 +27,23 @@ 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 named $^X, these are the legal values for X. @@ -442,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; } @@ -513,11 +514,7 @@ S_incline(pTHX_ char *s) ch = *t; *t = '\0'; if (t - s > 0) { -#ifdef USE_ITHREADS - Safefree(CopFILE(PL_curcop)); -#else - SvREFCNT_dec(CopFILEGV(PL_curcop)); -#endif + CopFILE_free(PL_curcop); CopFILE_set(PL_curcop, s); } *t = ch; @@ -633,6 +630,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); } } @@ -861,10 +860,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; @@ -875,7 +877,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); @@ -887,13 +890,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; } /* @@ -1419,7 +1424,9 @@ S_scan_const(pTHX_ char *start) /* FALL THROUGH */ default: { - if (ckWARN(WARN_MISC) && isALNUM(*s)) + if (ckWARN(WARN_MISC) && + isALNUM(*s) && + *s != '_') Perl_warner(aTHX_ WARN_MISC, "Unrecognized escape \\%c passed through", *s); @@ -1431,8 +1438,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; @@ -1442,20 +1450,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; } } @@ -1525,7 +1537,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 == '{') { @@ -1545,6 +1557,26 @@ S_scan_const(pTHX_ char *start) if (has_utf8) sv_utf8_upgrade(res); str = SvPV(res,len); +#ifdef EBCDIC_NEVER_MIND + /* charnames uses pack U and that has been + * recently changed to do the below uni->native + * mapping, so this would be redundant (and wrong, + * the code point would be doubly converted). + * But leave this in just in case the pack U change + * gets revoked, but the semantics is still + * desireable for charnames. --jhi */ + { + UV uv = utf8_to_uvchr((U8*)str, 0); + + if (uv < 0x100) { + U8 tmpbuf[UTF8_MAXLEN+1], *d; + + d = uvchr_to_utf8(tmpbuf, UNI_TO_NATIVE(uv)); + sv_setpvn(res, (char *)tmpbuf, d - tmpbuf); + str = SvPV(res, len); + } + } +#endif if (!has_utf8 && SvUTF8(res)) { char *ostart = SvPVX(sv); SvCUR_set(sv, d - ostart); @@ -1556,7 +1588,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))); @@ -1641,6 +1673,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) { @@ -1962,7 +1998,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); @@ -1974,7 +2010,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 */ @@ -2044,11 +2080,11 @@ 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 */ - return (*funcp)(aTHXo_ idx, buf_sv, maxlen); + return (*funcp)(aTHX_ idx, buf_sv, maxlen); } STATIC char * @@ -2166,132 +2202,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 */ @@ -2406,13 +2318,13 @@ Perl_yylex(pTHX) 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; @@ -2548,7 +2460,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...*/ @@ -2577,6 +2489,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; @@ -2660,6 +2574,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); @@ -2700,7 +2616,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); @@ -2790,6 +2706,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; @@ -2813,6 +2730,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); + } } } } @@ -3906,6 +3831,10 @@ Perl_yylex(pTHX) } else { /* no override */ tmp = -tmp; + if (tmp == KEY_dump && ckWARN(WARN_MISC)) { + Perl_warner(aTHX_ WARN_MISC, + "dump() better written as CORE::dump()"); + } gv = Nullgv; gvp = 0; if (ckWARN(WARN_AMBIGUOUS) && hgv @@ -4117,7 +4046,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); } @@ -4321,7 +4250,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: @@ -4651,7 +4580,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); @@ -4803,10 +4732,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)) @@ -4995,7 +4926,7 @@ Perl_yylex(pTHX) char tmpbuf[sizeof PL_tokenbuf]; SSize_t tboffset = 0; expectation attrful; - bool have_name, have_proto; + bool have_name, have_proto, bad_proto; int key = tmp; s = skipspace(s); @@ -5043,14 +4974,22 @@ Perl_yylex(pTHX) s = scan_str(s,FALSE,FALSE); if (!s) Perl_croak(aTHX_ "Prototype not terminated"); - /* strip spaces */ + /* strip spaces and check for bad characters */ d = SvPVX(PL_lex_stuff); tmp = 0; + bad_proto = FALSE; for (p = d; *p; ++p) { - if (!isSPACE(*p)) + if (!isSPACE(*p)) { d[tmp++] = *p; + if (!strchr("$@%*;[]&\\", *p)) + bad_proto = TRUE; + } } d[tmp] = '\0'; + if (bad_proto && ckWARN(WARN_SYNTAX)) + Perl_warner(aTHX_ WARN_SYNTAX, + "Illegal character in prototype for %s : %s", + SvPVX(PL_subname), d); SvCUR(PL_lex_stuff) = tmp; have_proto = TRUE; @@ -5166,15 +5105,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); @@ -5205,10 +5148,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 @@ -5236,6 +5178,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) + : GV_ADDMULTI + ), + ((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) { @@ -6505,6 +6578,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)) { @@ -6604,6 +6679,9 @@ S_scan_inputsymbol(pTHX_ char *start) return s; } else { + bool readline_overriden = FALSE; + GV *gv_readline = Nullgv; + GV **gvp; /* we're in a filehandle read situation */ d = PL_tokenbuf; @@ -6611,6 +6689,15 @@ S_scan_inputsymbol(pTHX_ char *start) if (!len) (void)strcpy(d,"ARGV"); + /* Check whether readline() is overriden */ + if (((gv_readline = gv_fetchpv("readline", FALSE, SVt_PVCV)) + && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline)) + || + ((gvp = (GV**)hv_fetch(PL_globalstash, "readline", 8, FALSE)) + && (gv_readline = *gvp) != (GV*)&PL_sv_undef + && GvCVu(gv_readline) && GvIMPORTED_CV(gv_readline))) + readline_overriden = TRUE; + /* if <$fh>, create the ops to turn the variable into a filehandle */ @@ -6621,15 +6708,41 @@ 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 = readline_overriden + ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, o, + newCVREF(0, newGVOP(OP_GV,0,gv_readline)))) + : (OP*)newUNOP(OP_READLINE, 0, o); + } } else { - GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV); - PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, - newUNOP(OP_RV2SV, 0, - newGVOP(OP_GV, 0, gv))); + GV *gv; + ++d; +intro_sym: + gv = gv_fetchpv(d, + (PL_in_eval + ? (GV_ADDMULTI | GV_ADDINEVAL) + : GV_ADDMULTI), + SVt_PV); + PL_lex_op = readline_overriden + ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, + newUNOP(OP_RV2SV, 0, newGVOP(OP_GV, 0, gv)), + newCVREF(0, newGVOP(OP_GV, 0, gv_readline)))) + : (OP*)newUNOP(OP_READLINE, 0, + newUNOP(OP_RV2SV, 0, + newGVOP(OP_GV, 0, gv))); } PL_lex_op->op_flags |= OPf_SPECIAL; /* we created the ops in PL_lex_op, so make yylval.ival a null op */ @@ -6640,7 +6753,12 @@ S_scan_inputsymbol(pTHX_ char *start) ( or ) so build a simple readline OP */ else { GV *gv = gv_fetchpv(d,TRUE, SVt_PVIO); - PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv)); + PL_lex_op = readline_overriden + ? (OP*)newUNOP(OP_ENTERSUB, OPf_STACKED, + append_elem(OP_LIST, + newGVOP(OP_GV, 0, gv), + newCVREF(0, newGVOP(OP_GV, 0, gv_readline)))) + : (OP*)newUNOP(OP_READLINE, 0, newGVOP(OP_GV, 0, gv)); yylval.ival = OP_NULL; } } @@ -6838,6 +6956,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); } @@ -6902,8 +7022,7 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) register char *e; /* end of temp buffer */ NV nv; /* number read, as a double */ SV *sv = Nullsv; /* place to put the converted number */ - bool floatit, /* boolean: int or float? */ - octal = 0; /* Is this an octal number? */ + bool floatit; /* boolean: int or float? */ char *lastub = 0; /* position of last underbar */ static char number_too_long[] = "Number too long"; @@ -6957,7 +7076,6 @@ Perl_scan_num(pTHX_ char *start, YYSTYPE* lvalp) /* so it must be octal */ else { shift = 3; - octal = 1; s++; } @@ -7160,7 +7278,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; } } @@ -7254,68 +7372,15 @@ 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; } /* make the op for the constant and return */ - if (sv) { + if (sv) lvalp->opval = newSVOP(OP_CONST, 0, sv); - if (octal) - ((SVOP *)lvalp->opval)->op_private |= OPpCONST_OCTAL; - } else lvalp->opval = Nullop; @@ -7357,15 +7422,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) { @@ -7446,11 +7515,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); @@ -7459,11 +7528,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; } @@ -7532,7 +7601,7 @@ Perl_yyerror(pTHX_ char *s) } msg = sv_2mortal(newSVpv(s, 0)); Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ", - CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); + OutCopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); if (context) Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context); else @@ -7550,10 +7619,10 @@ Perl_yyerror(pTHX_ char *s) if (PL_error_count >= 10) { if (PL_in_eval && SvCUR(ERRSV)) Perl_croak(aTHX_ "%"SVf"%s has too many errors.\n", - ERRSV, CopFILE(PL_curcop)); + ERRSV, OutCopFILE(PL_curcop)); else Perl_croak(aTHX_ "%s has too many errors.\n", - CopFILE(PL_curcop)); + OutCopFILE(PL_curcop)); } PL_in_my = 0; PL_in_my_stash = Nullhv; @@ -7638,17 +7707,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; @@ -7661,7 +7726,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) { @@ -7680,7 +7745,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) { @@ -7698,3 +7763,4 @@ utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen) return count; } #endif +