X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=c6d56edb5c7ce7e602aead94f1724e6a66d9153e;hb=d83e3bda142ab17f4cd2633e1fb9f48644dabcbf;hp=9b9db64ed4fd13b77e50154f21cd77bf32c6d12e;hpb=16d20bd98cd29be76029ebf04027a7edd34d817b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index 9b9db64..c6d56ed 100644 --- a/toke.c +++ b/toke.c @@ -16,6 +16,7 @@ static void check_uni _((void)); static void force_next _((I32 type)); +static char *force_version _((char *start)); static char *force_word _((char *start, int token, int check_keyword, int allow_pack, int allow_tick)); static SV *q _((SV *sv)); static char *scan_const _((char *start)); @@ -43,7 +44,10 @@ static I32 sublex_start _((void)); #ifdef CRIPPLED_CC static int uni _((I32 f, char *s)); #endif -static char * filter_gets _((SV *sv, FILE *fp)); +static char * filter_gets _((SV *sv, PerlIO *fp, STRLEN append)); +static void restore_rsfp _((void *f)); + +static char *linestart; /* beg. of most recently read line */ /* The following are arranged oddly so that the guard on the switch statement * can get by with a single comparison (if the compiler is smart enough). @@ -67,6 +71,12 @@ static char * filter_gets _((SV *sv, FILE *fp)); #include #endif +/* XXX If this causes problems, set i_unistd=undef in the hint file. */ +#ifdef I_UNISTD +# include /* Needed for execv() */ +#endif + + #ifdef ff_next #undef ff_next #endif @@ -139,7 +149,7 @@ char *s; { char tmpbuf[128]; char *oldbp = bufptr; - bool is_first = (oldbufptr == SvPVX(linestr)); + bool is_first = (oldbufptr == linestart); bufptr = s; sprintf(tmpbuf, "%s found where operator expected", what); yywarn(tmpbuf); @@ -219,10 +229,11 @@ SV *line; SAVEPPTR(bufend); SAVEPPTR(oldbufptr); SAVEPPTR(oldoldbufptr); + SAVEPPTR(linestart); SAVESPTR(linestr); SAVEPPTR(lex_brackstack); SAVEPPTR(lex_casestack); - SAVESPTR(rsfp); + SAVEDESTRUCTOR(restore_rsfp, rsfp); lex_state = LEX_NORMAL; lex_defer = 0; @@ -255,12 +266,10 @@ SV *line; sv_catpvn(linestr, "\n;", 2); } SvTEMP_off(linestr); - oldoldbufptr = oldbufptr = bufptr = SvPVX(linestr); + oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr); bufend = bufptr + SvCUR(linestr); - rs = "\n"; - rslen = 1; - rschar = '\n'; - rspara = 0; + SvREFCNT_dec(rs); + rs = newSVpv("\n", 1); rsfp = 0; } @@ -270,6 +279,19 @@ lex_end() } static void +restore_rsfp(f) +void *f; +{ + PerlIO *fp = (PerlIO*)f; + + if (rsfp == PerlIO_stdin()) + PerlIO_clearerr(rsfp); + else if (rsfp && (rsfp != fp)) + PerlIO_close(rsfp); + rsfp = fp; +} + +static void incline(s) char *s; { @@ -320,6 +342,7 @@ register char *s; return s; } for (;;) { + STRLEN prevlen; while (s < bufend && isSPACE(*s)) s++; if (s < bufend && *s == '#') { @@ -330,7 +353,7 @@ register char *s; } if (s < bufend || !rsfp || lex_state != LEX_NORMAL) return s; - if ((s = filter_gets(linestr, rsfp)) == Nullch) { + if ((s = filter_gets(linestr, rsfp, (prevlen = SvCUR(linestr)))) == Nullch) { if (minus_n || minus_p) { sv_setpv(linestr,minus_p ? ";}continue{print" : ""); sv_catpv(linestr,";}"); @@ -338,25 +361,26 @@ register char *s; } else sv_setpv(linestr,";"); - oldoldbufptr = oldbufptr = bufptr = s = SvPVX(linestr); + oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr); bufend = SvPVX(linestr) + SvCUR(linestr); if (preprocess && !in_eval) (void)my_pclose(rsfp); - else if ((FILE*)rsfp == stdin) - clearerr(stdin); + else if ((PerlIO*)rsfp == PerlIO_stdin()) + PerlIO_clearerr(rsfp); else - (void)fclose(rsfp); + (void)PerlIO_close(rsfp); rsfp = Nullfp; return s; } - oldoldbufptr = oldbufptr = bufptr = s; - bufend = bufptr + SvCUR(linestr); + linestart = bufptr = s + prevlen; + bufend = s + SvCUR(linestr); + s = bufptr; incline(s); if (perldb && curstash != debstash) { SV *sv = NEWSV(85,0); sv_upgrade(sv, SVt_PVMG); - sv_setsv(sv,linestr); + sv_setpvn(sv,bufptr,bufend-bufptr); av_store(GvAV(curcop->cop_filegv),(I32)curcop->cop_line,sv); } } @@ -503,6 +527,34 @@ int kind; } } +static char * +force_version(s) +char *s; +{ + OP *version = Nullop; + + s = skipspace(s); + + /* default VERSION number -- GBARR */ + + if(isDIGIT(*s)) { + char *d; + int c; + for( d=s, c = 1; isDIGIT(*d) || (*d == '.' && c--); d++); + if((*d == ';' || isSPACE(*d)) && *(skipspace(d)) != ',') { + s = scan_num(s); + /* real VERSION number -- GBARR */ + version = yylval.opval; + } + } + + /* NOTE: The parser sees the package name and the VERSION swapped */ + nextval[nexttoke].opval = version; + force_next(WORD); + + return (s); +} + static SV * q(sv) SV *sv; @@ -566,6 +618,7 @@ sublex_start() SAVEPPTR(bufptr); SAVEPPTR(oldbufptr); SAVEPPTR(oldoldbufptr); + SAVEPPTR(linestart); SAVESPTR(linestr); SAVEPPTR(lex_brackstack); SAVEPPTR(lex_casestack); @@ -573,7 +626,7 @@ sublex_start() linestr = lex_stuff; lex_stuff = Nullsv; - bufend = bufptr = oldbufptr = oldoldbufptr = SvPVX(linestr); + bufend = bufptr = oldbufptr = oldoldbufptr = linestart = SvPVX(linestr); bufend += SvCUR(linestr); SAVEFREESV(linestr); @@ -625,7 +678,7 @@ sublex_done() if (lex_repl && (lex_inwhat == OP_SUBST || lex_inwhat == OP_TRANS)) { linestr = lex_repl; lex_inpat = 0; - bufend = bufptr = oldbufptr = oldoldbufptr = SvPVX(linestr); + bufend = bufptr = oldbufptr = oldoldbufptr = linestart = SvPVX(linestr); bufend += SvCUR(linestr); SAVEFREESV(linestr); lex_dojoin = FALSE; @@ -678,8 +731,8 @@ char *start; SvGROW(sv, SvLEN(sv) + 256); d = SvPVX(sv) + i; d -= 2; - max = d[1] & 0377; - for (i = (*d & 0377); i <= max; i++) + max = (U8)d[1]; + for (i = (U8)*d; i <= max; i++) *d++ = i; dorange = FALSE; continue; @@ -953,7 +1006,7 @@ GV *gv; if (indirgv && GvCV(indirgv)) return 0; /* filehandle or package name makes it a method */ - if (!gv || GvIO(indirgv) || gv_stashpv(tmpbuf, FALSE)) { + if (!gv || GvIO(indirgv) || gv_stashpvn(tmpbuf, len, FALSE)) { s = skipspace(s); nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, @@ -1018,7 +1071,8 @@ filter_add(funcp, datasv) IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */ if (filter_debug) warn("filter_add func %lx (%s)", funcp, SvPV(datasv,na)); - av_push(rsfp_filters, datasv); + av_unshift(rsfp_filters, 1); + av_store(rsfp_filters, 0, datasv) ; return(datasv); } @@ -1033,8 +1087,10 @@ filter_del(funcp) if (!rsfp_filters || AvFILL(rsfp_filters)<0) return; /* if filter is on top of stack (usual case) just pop it off */ - if (IoDIRP(FILTER_DATA(AvFILL(rsfp_filters))) == (void*)funcp){ - sv_free(av_pop(rsfp_filters)); + if (IoDIRP(FILTER_DATA(0)) == (void*)funcp){ + /* sv_free(av_pop(rsfp_filters)); */ + sv_free(av_shift(rsfp_filters)); + return; } /* we need to search for the correct entry and clear it */ @@ -1051,12 +1107,12 @@ filter_read(idx, buf_sv, maxlen) { filter_t funcp; SV *datasv = NULL; + if (!rsfp_filters) return -1; if (idx > AvFILL(rsfp_filters)){ /* Any more filters? */ /* Provide a default input filter to make life easy. */ /* Note that we append to the line. This is handy. */ - /* We ignore maxlen here */ if (filter_debug) warn("filter_read %d: from rsfp\n", idx); if (maxlen) { @@ -1066,13 +1122,21 @@ filter_read(idx, buf_sv, maxlen) /* ensure buf_sv is large enough */ SvGROW(buf_sv, old_len + maxlen) ; - if ((len = fread(SvPVX(buf_sv) + old_len, 1, maxlen, rsfp)) <= 0) - return len ; + if ((len = PerlIO_read(rsfp, SvPVX(buf_sv) + old_len, maxlen)) <= 0){ + if (PerlIO_error(rsfp)) + return -1; /* error */ + else + return 0 ; /* end of file */ + } SvCUR_set(buf_sv, old_len + len) ; } else { /* Want a line */ - if (sv_gets(buf_sv, rsfp, (SvCUR(buf_sv)>0) ? 1 : 0) == NULL) - return -1; /* end of file */ + if (sv_gets(buf_sv, rsfp, SvCUR(buf_sv)) == NULL) { + if (PerlIO_error(rsfp)) + return -1; /* error */ + else + return 0 ; /* end of file */ + } } return SvCUR(buf_sv); } @@ -1089,14 +1153,15 @@ filter_read(idx, buf_sv, maxlen) idx, funcp, SvPV(datasv,na)); /* Call function. The function is expected to */ /* call "FILTER_READ(idx+1, buf_sv)" first. */ - /* Return: <0:error/eof, >=0:not eof (see yylex()) */ + /* Return: <0:error, =0:eof, >0:not eof */ return (*funcp)(idx, buf_sv, maxlen); } static char * -filter_gets(sv,fp) +filter_gets(sv,fp, append) register SV *sv; -register FILE *fp; +register PerlIO *fp; +STRLEN append; { if (rsfp_filters) { @@ -1107,7 +1172,7 @@ register FILE *fp; return Nullch ; } else - return (sv_gets(sv, fp, 0)) ; + return (sv_gets(sv, fp, append)); } @@ -1176,7 +1241,7 @@ yylex() return ')'; } if (lex_casemods > 10) { - char* newlb = (char*)realloc(lex_casestack, lex_casemods + 2); + char* newlb = Renew(lex_casestack, lex_casemods + 2, char); if (newlb != lex_casestack) { SAVEFREEPV(newlb); lex_casestack = newlb; @@ -1297,7 +1362,7 @@ yylex() oldoldbufptr = oldbufptr; oldbufptr = s; DEBUG_p( { - fprintf(stderr,"### Tokener expecting %s at %s\n", exp_name[expect], s); + PerlIO_printf(PerlIO_stderr(), "### Tokener expecting %s at %s\n", exp_name[expect], s); } ) retry: @@ -1321,8 +1386,18 @@ yylex() if (!in_eval && !preambled) { preambled = TRUE; sv_setpv(linestr,incl_perldb()); - if (autoboot_preamble) - sv_catpv(linestr, autoboot_preamble); + if (SvCUR(linestr)) + sv_catpv(linestr,";"); + if (preambleav){ + while(AvFILL(preambleav) >= 0) { + SV *tmpsv = av_shift(preambleav); + sv_catsv(linestr, tmpsv); + sv_catpv(linestr, ";"); + sv_free(tmpsv); + } + sv_free((SV*)preambleav); + preambleav = NULL; + } if (minus_n || minus_p) { sv_catpv(linestr, "LINE: while (<>) {"); if (minus_l) @@ -1343,7 +1418,7 @@ yylex() } } sv_catpv(linestr, "\n"); - oldoldbufptr = oldbufptr = s = SvPVX(linestr); + oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr); bufend = SvPVX(linestr) + SvCUR(linestr); if (perldb && curstash != debstash) { SV *sv = NEWSV(85,0); @@ -1355,26 +1430,26 @@ yylex() goto retry; } do { - if ((s = filter_gets(linestr, rsfp)) == Nullch) { + if ((s = filter_gets(linestr, rsfp, 0)) == Nullch) { fake_eof: if (rsfp) { if (preprocess && !in_eval) (void)my_pclose(rsfp); - else if ((FILE*)rsfp == stdin) - clearerr(stdin); + else if ((PerlIO *)rsfp == PerlIO_stdin()) + PerlIO_clearerr(rsfp); else - (void)fclose(rsfp); + (void)PerlIO_close(rsfp); rsfp = Nullfp; } if (!in_eval && (minus_n || minus_p)) { sv_setpv(linestr,minus_p ? ";}continue{print" : ""); sv_catpv(linestr,";}"); - oldoldbufptr = oldbufptr = s = SvPVX(linestr); + oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr); bufend = SvPVX(linestr) + SvCUR(linestr); minus_n = minus_p = 0; goto retry; } - oldoldbufptr = oldbufptr = s = SvPVX(linestr); + oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr); sv_setpv(linestr,""); TOKEN(';'); /* not infinite loop because rsfp is NULL now */ } @@ -1385,14 +1460,14 @@ yylex() /* Incest with pod. */ if (*s == '=' && strnEQ(s, "=cut", 4)) { sv_setpv(linestr, ""); - oldoldbufptr = oldbufptr = s = SvPVX(linestr); + oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr); bufend = SvPVX(linestr) + SvCUR(linestr); doextract = FALSE; } } incline(s); } while (doextract); - oldoldbufptr = oldbufptr = bufptr = s; + oldoldbufptr = oldbufptr = bufptr = linestart = s; if (perldb && curstash != debstash) { SV *sv = NEWSV(85,0); @@ -1447,16 +1522,17 @@ yylex() int oldp = minus_p; while (*d && !isSPACE(*d)) d++; - while (*d == ' ') d++; + while (*d == ' ' || *d == '\t') d++; if (*d++ == '-') { while (d = moreswitches(d)) ; if (perldb && !oldpdb || - minus_n && !oldn || - minus_p && !oldp) + ( minus_n || minus_p ) && !(oldn || oldp) ) + /* if we have already added "LINE: while (<>) {", + we must not do it again */ { sv_setpv(linestr, ""); - oldoldbufptr = oldbufptr = s = SvPVX(linestr); + oldoldbufptr = oldbufptr = s = linestart = SvPVX(linestr); bufend = SvPVX(linestr) + SvCUR(linestr); preambled = FALSE; if (perldb) @@ -1686,12 +1762,12 @@ yylex() lex_state = LEX_INTERPEND; } } - TOKEN(']'); + TERM(']'); case '{': leftbracket: s++; if (lex_brackets > 100) { - char* newlb = (char*)realloc(lex_brackstack, lex_brackets + 1); + char* newlb = Renew(lex_brackstack, lex_brackets + 1, char); if (newlb != lex_brackstack) { SAVEFREEPV(newlb); lex_brackstack = newlb; @@ -1712,7 +1788,7 @@ yylex() case XOPERATOR: while (s < bufend && (*s == ' ' || *s == '\t')) s++; - if (s < bufend && isALPHA(*s)) { + if (s < bufend && (isALPHA(*s) || *s == '_')) { d = scan_word(s, tokenbuf, FALSE, &len); while (d < bufend && (*d == ' ' || *d == '\t')) d++; @@ -1744,7 +1820,7 @@ yylex() if (*s == '}') OPERATOR(HASHBRACK); if (isALPHA(*s)) { - for (t = s; t < bufend && isALPHA(*t); t++) ; + for (t = s; t < bufend && isALNUM(*t); t++) ; } else if (*s == '\'' || *s == '"') { t = strchr(s+1,*s); @@ -1804,7 +1880,7 @@ yylex() AOPERATOR(ANDAND); s--; if (expect == XOPERATOR) { - if (isALPHA(*s) && bufptr == SvPVX(linestr)) { + if (dowarn && isALPHA(*s) && bufptr == linestart) { curcop->cop_line--; warn(warn_nosemi); curcop->cop_line++; @@ -1819,6 +1895,7 @@ yylex() } else PREREF('&'); + yylval.ival = (OPpENTERSUB_AMPER<<8); TERM('&'); case '|': @@ -1841,8 +1918,26 @@ yylex() warn("Reversed %c= operator",tmp); s--; if (expect == XSTATE && isALPHA(tmp) && - (s == SvPVX(linestr)+1 || s[-2] == '\n') ) + (s == linestart+1 || s[-2] == '\n') ) { + if (in_eval && !rsfp) { + d = bufend; + while (s < d) { + if (*s++ == '\n') { + incline(s); + if (strnEQ(s,"=cut",4)) { + s = strchr(s,'\n'); + if (s) + s++; + else + s = d; + incline(s); + goto retry; + } + } + } + goto retry; + } s = bufend; doextract = TRUE; goto retry; @@ -2000,25 +2095,34 @@ yylex() } else if (!strchr(tokenbuf,':')) { if (oldexpect != XREF || oldoldbufptr == last_lop) { - if (*s == '[') - tokenbuf[0] = '@'; - else if (*s == '{') - tokenbuf[0] = '%'; + if (intuit_more(s)) { + if (*s == '[') + tokenbuf[0] = '@'; + else if (*s == '{') + tokenbuf[0] = '%'; + } } if (tmp = pad_findmy(tokenbuf)) { + if (last_lop_op == OP_SORT && + !tokenbuf[2] && *tokenbuf =='$' && + tokenbuf[1] <= 'b' && tokenbuf[1] >= 'a') + { + for (d = in_eval ? oldoldbufptr : linestart; + d < bufend && *d != '\n'; + d++) + { + if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) { + croak("Can't use \"my %s\" in sort comparison", + tokenbuf); + } + } + } nextval[nexttoke].opval = newOP(OP_PADANY, 0); nextval[nexttoke].opval->op_targ = tmp; force_next(PRIVATEREF); } - else { - if ((tainting || !euid) && - !isLOWER(tokenbuf[1]) && - (isDIGIT(tokenbuf[1]) || - strchr("&`'+", tokenbuf[1]) || - instr(tokenbuf,"MATCH") )) - hints |= HINT_BLOCK_SCOPE; /* Can't optimize block out*/ + else force_ident(tokenbuf+1, *tokenbuf); - } } else force_ident(tokenbuf+1, *tokenbuf); @@ -2048,8 +2152,10 @@ yylex() TERM('@'); } else if (!strchr(tokenbuf,':')) { - if (*s == '{') - tokenbuf[0] = '%'; + if (intuit_more(s)) { + if (*s == '{') + tokenbuf[0] = '%'; + } if (tmp = pad_findmy(tokenbuf)) { nextval[nexttoke].opval = newOP(OP_PADANY, 0); nextval[nexttoke].opval->op_targ = tmp; @@ -2059,7 +2165,7 @@ yylex() } /* Force them to make up their mind on "@foo". */ - if (lex_state != LEX_NORMAL && + if (lex_state != LEX_NORMAL && !lex_brackets && ( !(gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV)) || (*tokenbuf == '@' ? !GvAV(gv) @@ -2107,7 +2213,7 @@ yylex() case '.': if (lex_formbrack && lex_brackets == lex_formbrack && s[1] == '\n' && - (s == SvPVX(linestr) || s[-1] == '\n') ) { + (s == linestart || s[-1] == '\n') ) { lex_formbrack = 0; expect = XSTATE; goto rightbracket; @@ -2165,7 +2271,13 @@ yylex() } if (!s) missingterm((char*)0); - yylval.ival = OP_STRINGIFY; + yylval.ival = OP_CONST; + for (d = SvPV(lex_stuff, len); len; len--, d++) { + if (*d == '$' || *d == '@' || *d == '\\') { + yylval.ival = OP_STRINGIFY; + break; + } + } TERM(sublex_start()); case '`': @@ -2225,6 +2337,9 @@ yylex() bufptr = s; s = scan_word(s, tokenbuf, FALSE, &len); + if (*s == ':' && s[1] == ':' && strNE(tokenbuf, "CORE")) + goto just_a_word; + tmp = keyword(tokenbuf, len); /* Is this a word before a => operator? */ @@ -2244,10 +2359,9 @@ yylex() if (tmp < 0) { /* second-class keyword? */ GV* gv; if (expect != XOPERATOR && - (*s != ':' || s[1] != ':') && - (gv = gv_fetchpv(tokenbuf,FALSE, SVt_PVCV)) && - (GvFLAGS(gv) & GVf_IMPORTED) && - GvCV(gv)) + (*s != ':' || s[1] != ':') && + (gv = gv_fetchpv(tokenbuf, FALSE, SVt_PVCV)) && + GvIMPORTED_CV(gv)) { tmp = 0; } @@ -2283,7 +2397,7 @@ yylex() } } else if (expect == XOPERATOR) { - if (bufptr == SvPVX(linestr)) { + if (bufptr == linestart) { curcop->cop_line--; warn(warn_nosemi); curcop->cop_line++; @@ -2324,8 +2438,9 @@ yylex() /* If not a declared subroutine, it's an indirect object. */ /* (But it's an indir obj regardless for sort.) */ - if (last_lop_op == OP_SORT || - (!immediate_paren && (!gv || !GvCV(gv))) ) { + if ((last_lop_op == OP_SORT || + (!immediate_paren && (!gv || !GvCV(gv))) ) && + (last_lop_op != OP_MAPSTART && last_lop_op != OP_GREPSTART)){ expect = (last_lop == oldoldbufptr) ? XTERM : XOPERATOR; goto bareword; } @@ -2340,6 +2455,7 @@ yylex() nextval[nexttoke].opval = yylval.opval; expect = XOPERATOR; force_next(WORD); + yylval.ival = 0; TOKEN('&'); } @@ -2359,17 +2475,47 @@ yylex() /* Not a method, so call it a subroutine (if defined) */ if (gv && GvCV(gv)) { - nextval[nexttoke].opval = yylval.opval; + CV* cv = GvCV(gv); if (*s == '(') { + nextval[nexttoke].opval = yylval.opval; expect = XTERM; force_next(WORD); + yylval.ival = 0; TOKEN('&'); } if (lastchar == '-') - warn("Ambiguious use of -%s resolved as -&%s()", + warn("Ambiguous use of -%s resolved as -&%s()", tokenbuf, tokenbuf); last_lop = oldbufptr; last_lop_op = OP_ENTERSUB; + /* Check for a constant sub */ + { + SV *sv = cv_const_sv(cv); + if (sv) { + SvREFCNT_dec(((SVOP*)yylval.opval)->op_sv); + ((SVOP*)yylval.opval)->op_sv = SvREFCNT_inc(sv); + yylval.opval->op_private = 0; + TOKEN(WORD); + } + } + + /* Resolve to GV now. */ + op_free(yylval.opval); + yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv)); + /* Is there a prototype? */ + if (SvPOK(cv)) { + STRLEN len; + char *proto = SvPV((SV*)cv, len); + if (!len) + TERM(FUNC0SUB); + if (strEQ(proto, "$")) + OPERATOR(UNIOPSUB); + if (*proto == '&' && *s == '{') { + sv_setpv(subname,"__ANON__"); + PREBLOCK(LSTOPSUB); + } + } + nextval[nexttoke].opval = yylval.opval; expect = XTERM; force_next(WORD); TOKEN(NOAMP); @@ -2378,6 +2524,7 @@ yylex() if (hints & HINT_STRICT_SUBS && lastchar != '-' && strnNE(s,"->",2) && + last_lop_op != OP_TRUNCATE && /* S/F prototype in opcode.pl */ last_lop_op != OP_ACCEPT && last_lop_op != OP_PIPE_OP && last_lop_op != OP_SOCKPAIR) @@ -2401,7 +2548,7 @@ yylex() if (lastchar && strchr("*%&", lastchar)) { warn("Operator or semicolon missing before %c%s", lastchar, tokenbuf); - warn("Ambiguious use of %c resolved as operator %c", + warn("Ambiguous use of %c resolved as operator %c", lastchar, lastchar); } TOKEN(WORD); @@ -2417,25 +2564,33 @@ yylex() TERM(THING); } + case KEY___DATA__: case KEY___END__: { GV *gv; /*SUPPRESS 560*/ - if (!in_eval) { - gv = gv_fetchpv("main::DATA",TRUE, SVt_PVIO); - SvMULTI_on(gv); + if (rsfp && (!in_eval || tokenbuf[2] == 'D')) { + char dname[256]; + char *pname = "main"; + if (tokenbuf[2] == 'D') + pname = HvNAME(curstash ? curstash : defstash); + sprintf(dname,"%s::DATA", pname); + gv = gv_fetchpv(dname,TRUE, SVt_PVIO); + GvMULTI_on(gv); if (!GvIO(gv)) GvIOp(gv) = newIO(); IoIFP(GvIOp(gv)) = rsfp; #if defined(HAS_FCNTL) && defined(F_SETFD) { - int fd = fileno(rsfp); + int fd = PerlIO_fileno(rsfp); fcntl(fd,F_SETFD,fd >= 3); } #endif + /* Mark this internal pseudo-handle as clean */ + IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT; if (preprocess) IoTYPE(GvIOp(gv)) = '|'; - else if ((FILE*)rsfp == stdin) + else if ((PerlIO*)rsfp == PerlIO_stdin()) IoTYPE(GvIOp(gv)) = '-'; else IoTYPE(GvIOp(gv)) = '<'; @@ -2846,6 +3001,7 @@ yylex() if (expect != XSTATE) yyerror("\"no\" not allowed in expression"); s = force_word(s,WORD,FALSE,TRUE,FALSE); + s = force_version(s); yylval.ival = 0; OPERATOR(USE); @@ -2885,6 +3041,9 @@ yylex() checkcomma(s,tokenbuf,"filehandle"); LOP(OP_PRTF,XREF); + case KEY_prototype: + UNI(OP_PROTOTYPE); + case KEY_push: LOP(OP_PUSH,XTERM); @@ -2958,7 +3117,7 @@ yylex() *tokenbuf = '\0'; s = force_word(s,WORD,TRUE,TRUE,FALSE); if (isIDFIRST(*tokenbuf)) - gv_stashpv(tokenbuf, TRUE); + gv_stashpvn(tokenbuf, strlen(tokenbuf), TRUE); else if (*s == '<') yyerror("<> should be quotes"); UNI(OP_REQUIRE); @@ -3140,13 +3299,10 @@ yylex() case KEY_sub: really_sub: s = skipspace(s); - if (*s == '{' && tmp == KEY_sub) { - sv_setpv(subname,"__ANON__"); - PRETERMBLOCK(ANONSUB); - } - expect = XBLOCK; + if (isIDFIRST(*s) || *s == '\'' || *s == ':') { char tmpbuf[128]; + expect = XBLOCK; d = scan_word(s, tmpbuf, TRUE, &len); if (strchr(tmpbuf, ':')) sv_setpv(subname, tmpbuf); @@ -3156,17 +3312,47 @@ yylex() sv_catpvn(subname,tmpbuf,len); } s = force_word(s,WORD,FALSE,TRUE,TRUE); + s = skipspace(s); } - else + else { + expect = XTERMBLOCK; sv_setpv(subname,"?"); + } - if (tmp != KEY_format) - PREBLOCK(SUB); + if (tmp == KEY_format) { + s = skipspace(s); + if (*s == '=') + lex_formbrack = lex_brackets + 1; + OPERATOR(FORMAT); + } - s = skipspace(s); - if (*s == '=') - lex_formbrack = lex_brackets + 1; - OPERATOR(FORMAT); + /* Look for a prototype */ + if (*s == '(') { + s = scan_str(s); + if (!s) { + if (lex_stuff) + SvREFCNT_dec(lex_stuff); + lex_stuff = Nullsv; + croak("Prototype not terminated"); + } + nexttoke++; + nextval[1] = nextval[0]; + nexttype[1] = nexttype[0]; + nextval[0].opval = (OP*)newSVOP(OP_CONST, 0, lex_stuff); + nexttype[0] = THING; + if (nexttoke == 1) { + lex_defer = lex_state; + lex_expect = expect; + lex_state = LEX_KNOWNEXT; + } + lex_stuff = Nullsv; + } + + if (*SvPV(subname,na) == '?') { + sv_setpv(subname,"__ANON__"); + TOKEN(ANONSUB); + } + PREBLOCK(SUB); case KEY_system: set_csh(); @@ -3178,6 +3364,9 @@ yylex() case KEY_syscall: LOP(OP_SYSCALL,XTERM); + case KEY_sysopen: + LOP(OP_SYSOPEN,XTERM); + case KEY_sysread: LOP(OP_SYSREAD,XTERM); @@ -3197,6 +3386,9 @@ yylex() case KEY_tie: LOP(OP_TIE,XTERM); + case KEY_tied: + UNI(OP_TIED); + case KEY_time: FUN0(OP_TIME); @@ -3249,7 +3441,18 @@ yylex() case KEY_use: if (expect != XSTATE) yyerror("\"use\" not allowed in expression"); - s = force_word(s,WORD,FALSE,TRUE,FALSE); + s = skipspace(s); + if(isDIGIT(*s)) { + s = force_version(s); + if(*s == ';' || (s = skipspace(s), *s == ';')) { + nextval[nexttoke].opval = Nullop; + force_next(WORD); + } + } + else { + s = force_word(s,WORD,FALSE,TRUE,FALSE); + s = force_version(s); + } yylval.ival = 1; OPERATOR(USE); @@ -3308,6 +3511,7 @@ I32 len; if (d[1] == '_') { if (strEQ(d,"__LINE__")) return -KEY___LINE__; if (strEQ(d,"__FILE__")) return -KEY___FILE__; + if (strEQ(d,"__DATA__")) return KEY___DATA__; if (strEQ(d,"__END__")) return KEY___END__; } break; @@ -3422,6 +3626,7 @@ I32 len; break; case 6: if (strEQ(d,"exists")) return KEY_exists; + if (strEQ(d,"elseif")) warn("elseif should be elsif"); break; case 8: if (strEQ(d,"endgrent")) return -KEY_endgrent; @@ -3667,6 +3872,8 @@ I32 len; case 7: if (strEQ(d,"package")) return KEY_package; break; + case 9: + if (strEQ(d,"prototype")) return KEY_prototype; } break; case 'q': @@ -3809,6 +4016,7 @@ I32 len; if (strEQ(d,"system")) return -KEY_system; break; case 7: + if (strEQ(d,"sysopen")) return -KEY_sysopen; if (strEQ(d,"sysread")) return -KEY_sysread; if (strEQ(d,"symlink")) return -KEY_symlink; if (strEQ(d,"syscall")) return -KEY_syscall; @@ -3830,6 +4038,7 @@ I32 len; break; case 4: if (strEQ(d,"tell")) return -KEY_tell; + if (strEQ(d,"tied")) return KEY_tied; if (strEQ(d,"time")) return -KEY_time; break; case 5: @@ -3940,7 +4149,7 @@ char *what; if (*s == ',') { int kw; *s = '\0'; - kw = keyword(w, s - w); + kw = keyword(w, s - w) || perl_get_cv(w, FALSE) != 0; *s = ','; if (kw) return; @@ -4121,6 +4330,7 @@ char *start; while (*s && strchr("iogmsx", *s)) pmflag(&pm->op_pmflags,*s++); + pm->op_pmpermflags = pm->op_pmflags; lex_op = (OP*)pm; yylval.ival = OP_MATCH; return s; @@ -4183,6 +4393,7 @@ char *start; lex_repl = repl; } + pm->op_pmpermflags = pm->op_pmflags; lex_op = (OP*)pm; yylval.ival = OP_SUBST; return s; @@ -4292,12 +4503,15 @@ register char *s; SV *tmpstr; char term; register char *d; + char *peek; s += 2; d = tokenbuf; if (!rsfp) *d++ = '\n'; - if (*s && strchr("`'\"",*s)) { + for (peek = s; *peek == ' ' || *peek == '\t'; peek++) ; + if (*peek && strchr("`'\"",*peek)) { + s = peek; term = *s++; s = cpytill(d,s,bufend,term,&len); if (s < bufend) @@ -4309,6 +4523,8 @@ register char *s; s++, term = '\''; else term = '"'; + if (!isALNUM(*s)) + deprecate("bare << to mean <<\"\""); while (isALNUM(*s)) *d++ = *s++; } /* assuming tokenbuf won't clobber */ @@ -4340,7 +4556,7 @@ register char *s; if (!rsfp) { d = s; while (s < bufend && - (*s != term || bcmp(s,tokenbuf,len) != 0) ) { + (*s != term || memcmp(s,tokenbuf,len) != 0) ) { if (*s++ == '\n') curcop->cop_line++; } @@ -4352,14 +4568,14 @@ register char *s; s += len - 1; sv_catpvn(herewas,s,bufend-s); sv_setsv(linestr,herewas); - oldoldbufptr = oldbufptr = bufptr = s = SvPVX(linestr); + oldoldbufptr = oldbufptr = bufptr = s = linestart = SvPVX(linestr); bufend = SvPVX(linestr) + SvCUR(linestr); } else sv_setpvn(tmpstr,"",0); /* avoid "uninitialized" warning */ while (s >= bufend) { /* multiple line string? */ if (!rsfp || - !(oldoldbufptr = oldbufptr = s = filter_gets(linestr, rsfp))) { + !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) { curcop->cop_line = multi_start; missingterm(tokenbuf); } @@ -4373,7 +4589,7 @@ register char *s; (I32)curcop->cop_line,sv); } bufend = SvPVX(linestr) + SvCUR(linestr); - if (*s == term && bcmp(s,tokenbuf,len) == 0) { + if (*s == term && memcmp(s,tokenbuf,len) == 0) { s = bufend - 1; *s = ' '; sv_catsv(linestr,herewas); @@ -4411,7 +4627,7 @@ char *start; else croak("Unterminated <> operator"); - if (*d == '$') d++; + if (*d == '$' && d[1]) d++; while (*d && (isALNUM(*d) || *d == '\'' || *d == ':')) d++; if (d - tokenbuf != len) { @@ -4518,7 +4734,8 @@ char *start; if (s < bufend) break; /* string ends on this line? */ if (!rsfp || - !(oldoldbufptr = oldbufptr = s = filter_gets(linestr, rsfp))) { + !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) { + sv_free(sv); curcop->cop_line = multi_start; return Nullch; } @@ -4696,8 +4913,8 @@ register char *s; } s = eol; if (rsfp) { - s = filter_gets(linestr, rsfp); - oldoldbufptr = oldbufptr = bufptr = SvPVX(linestr); + s = filter_gets(linestr, rsfp, 0); + oldoldbufptr = oldbufptr = bufptr = linestart = SvPVX(linestr); bufend = bufptr + SvCUR(linestr); if (!s) { s = bufptr; @@ -4746,9 +4963,11 @@ start_subparse() CV* outsidecv = compcv; AV* comppadlist; +#ifndef __QNX__ if (compcv) { assert(SvTYPE(compcv) == SVt_PVCV); } +#endif save_I32(&subline); save_item(subname); SAVEINT(padix); @@ -4765,9 +4984,7 @@ start_subparse() sv_upgrade((SV *)compcv, SVt_PVCV); comppad = newAV(); - SAVEFREESV((SV*)comppad); comppad_name = newAV(); - SAVEFREESV((SV*)comppad_name); comppad_name_fill = 0; min_intro_pending = 0; av_push(comppad, Nullsv); @@ -4777,8 +4994,8 @@ start_subparse() comppadlist = newAV(); AvREAL_off(comppadlist); - av_store(comppadlist, 0, SvREFCNT_inc((SV*)comppad_name)); - av_store(comppadlist, 1, SvREFCNT_inc((SV*)comppad)); + av_store(comppadlist, 0, (SV*)comppad_name); + av_store(comppadlist, 1, (SV*)comppad); CvPADLIST(compcv) = comppadlist; CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc((SV*)outsidecv); @@ -4824,6 +5041,8 @@ char *s; if (lex_state == LEX_NORMAL || (lex_state == LEX_KNOWNEXT && lex_defer == LEX_NORMAL)) (void)strcpy(tname,"at end of line"); + else if (lex_inpat) + (void)strcpy(tname,"within pattern"); else (void)strcpy(tname,"within string"); } @@ -4842,11 +5061,12 @@ char *s; if (in_eval & 2) warn("%s",buf); else if (in_eval) - sv_catpv(GvSV(gv_fetchpv("@",TRUE, SVt_PV)),buf); + sv_catpv(GvSV(errgv),buf); else - fputs(buf,stderr); + PerlIO_printf(PerlIO_stderr(), "%s",buf); if (++error_count >= 10) croak("%s has too many errors.\n", SvPVX(GvSV(curcop->cop_filegv))); + in_my = 0; return 0; }