X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=c6d56edb5c7ce7e602aead94f1724e6a66d9153e;hb=d83e3bda142ab17f4cd2633e1fb9f48644dabcbf;hp=cdb12a361f2a686df0d9e15062157a637b2b78bd;hpb=8e07c86ebc651fe92eb7e3b25f801f57cfb8dd6f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index cdb12a3..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, @@ -1069,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); } @@ -1092,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) { @@ -1110,7 +1172,7 @@ register FILE *fp; return Nullch ; } else - return (sv_gets(sv, fp, 0)) ; + return (sv_gets(sv, fp, append)); } @@ -1179,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; @@ -1300,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: @@ -1324,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) @@ -1346,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); @@ -1358,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 */ } @@ -1388,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); @@ -1450,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) @@ -1689,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; @@ -1715,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++; @@ -1747,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); @@ -1807,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++; @@ -1822,6 +1895,7 @@ yylex() } else PREREF('&'); + yylval.ival = (OPpENTERSUB_AMPER<<8); TERM('&'); case '|': @@ -1844,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; @@ -2003,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); @@ -2051,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; @@ -2062,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) @@ -2110,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; @@ -2168,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 '`': @@ -2228,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? */ @@ -2247,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; } @@ -2286,7 +2397,7 @@ yylex() } } else if (expect == XOPERATOR) { - if (bufptr == SvPVX(linestr)) { + if (bufptr == linestart) { curcop->cop_line--; warn(warn_nosemi); curcop->cop_line++; @@ -2344,6 +2455,7 @@ yylex() nextval[nexttoke].opval = yylval.opval; expect = XOPERATOR; force_next(WORD); + yylval.ival = 0; TOKEN('&'); } @@ -2363,10 +2475,12 @@ 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 == '-') @@ -2374,6 +2488,34 @@ yylex() 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); @@ -2382,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) @@ -2426,26 +2569,28 @@ yylex() GV *gv; /*SUPPRESS 560*/ - if (!in_eval || tokenbuf[2] == 'D') { + 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); - SvMULTI_on(gv); + 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)) = '<'; @@ -2856,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); @@ -2895,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); @@ -2968,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); @@ -3150,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); @@ -3166,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(); @@ -3188,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); @@ -3207,6 +3386,9 @@ yylex() case KEY_tie: LOP(OP_TIE,XTERM); + case KEY_tied: + UNI(OP_TIED); + case KEY_time: FUN0(OP_TIME); @@ -3259,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); @@ -3433,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; @@ -3678,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': @@ -3820,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; @@ -3841,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: @@ -3951,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; @@ -4132,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; @@ -4194,6 +4393,7 @@ char *start; lex_repl = repl; } + pm->op_pmpermflags = pm->op_pmflags; lex_op = (OP*)pm; yylval.ival = OP_SUBST; return s; @@ -4303,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) @@ -4320,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 */ @@ -4351,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++; } @@ -4363,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); } @@ -4384,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); @@ -4422,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) { @@ -4529,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; } @@ -4707,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; @@ -4757,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); @@ -4833,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"); } @@ -4851,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; }