X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=24805a7d38e38cdf5ffd399c89ce13101d77bf66;hb=fa83b5b6263413f922909c255e021c32c808b32d;hp=99d0e6182caa80967fba824478ec4455592066f7;hpb=748a93069b3d16374a9859d1456065dd3ae11394;p=p5sagit%2Fp5-mst-13.2.git diff --git a/toke.c b/toke.c index 99d0e61..24805a7 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)); @@ -39,25 +40,39 @@ static void missingterm _((char *s)); static void no_op _((char *what, char *s)); static void set_csh _((void)); static I32 sublex_done _((void)); +static I32 sublex_push _((void)); static I32 sublex_start _((void)); #ifdef CRIPPLED_CC static int uni _((I32 f, char *s)); #endif +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 */ + +static char pending_ident; /* pending identifier lookup */ + +static struct { + I32 super_state; /* lexer state to save */ + I32 sub_inwhat; /* "lex_inwhat" to use */ + OP *sub_op; /* "lex_op" to use */ +} sublex_info; /* 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). */ -#define LEX_NORMAL 9 -#define LEX_INTERPNORMAL 8 -#define LEX_INTERPCASEMOD 7 -#define LEX_INTERPSTART 6 -#define LEX_INTERPEND 5 -#define LEX_INTERPENDMAYBE 4 -#define LEX_INTERPCONCAT 3 -#define LEX_INTERPCONST 2 -#define LEX_FORMLINE 1 -#define LEX_KNOWNEXT 0 +#define LEX_NORMAL 10 +#define LEX_INTERPNORMAL 9 +#define LEX_INTERPCASEMOD 8 +#define LEX_INTERPPUSH 7 +#define LEX_INTERPSTART 6 +#define LEX_INTERPEND 5 +#define LEX_INTERPENDMAYBE 4 +#define LEX_INTERPCONCAT 3 +#define LEX_INTERPCONST 2 +#define LEX_FORMLINE 1 +#define LEX_KNOWNEXT 0 #ifdef I_FCNTL #include @@ -66,6 +81,12 @@ static int uni _((I32 f, char *s)); #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 @@ -138,7 +159,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); @@ -170,7 +191,7 @@ char *s; } else if (multi_close < 32 || multi_close == 127) { *tmpbuf = '^'; - tmpbuf[1] = multi_close ^ 64; + tmpbuf[1] = toCTRL(multi_close); s = "\\n"; tmpbuf[2] = '\0'; s = tmpbuf; @@ -205,23 +226,24 @@ SV *line; char *s; STRLEN len; - SAVEINT(lex_dojoin); - SAVEINT(lex_brackets); - SAVEINT(lex_fakebrack); - SAVEINT(lex_casemods); - SAVEINT(lex_starts); - SAVEINT(lex_state); + SAVEI32(lex_dojoin); + SAVEI32(lex_brackets); + SAVEI32(lex_fakebrack); + SAVEI32(lex_casemods); + SAVEI32(lex_starts); + SAVEI32(lex_state); SAVESPTR(lex_inpat); - SAVEINT(lex_inwhat); - SAVEINT(curcop->cop_line); + SAVEI32(lex_inwhat); + SAVEI16(curcop->cop_line); SAVEPPTR(bufptr); 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; @@ -254,18 +276,30 @@ 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; } void lex_end() { + doextract = FALSE; +} + +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 @@ -319,6 +353,7 @@ register char *s; return s; } for (;;) { + STRLEN prevlen; while (s < bufend && isSPACE(*s)) s++; if (s < bufend && *s == '#') { @@ -329,7 +364,7 @@ register char *s; } if (s < bufend || !rsfp || lex_state != LEX_NORMAL) return s; - if ((s = sv_gets(linestr, rsfp, 0)) == 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,";}"); @@ -337,25 +372,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); } } @@ -492,7 +528,10 @@ int kind; force_next(WORD); if (kind) { op->op_private = OPpCONST_ENTERED; - gv_fetchpv(s, TRUE, + /* XXX see note in pp_entereval() for why we forgo typo + warnings if the symbol must be introduced in an eval. + GSAR 96-10-12 */ + gv_fetchpv(s, in_eval ? GV_ADDMULTI : TRUE, kind == '$' ? SVt_PV : kind == '@' ? SVt_PVAV : kind == '%' ? SVt_PVHV : @@ -502,6 +541,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 == '_' || (*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; @@ -552,19 +619,40 @@ sublex_start() return THING; } + sublex_info.super_state = lex_state; + sublex_info.sub_inwhat = op_type; + sublex_info.sub_op = lex_op; + lex_state = LEX_INTERPPUSH; + + expect = XTERM; + if (lex_op) { + yylval.opval = lex_op; + lex_op = Nullop; + return PMFUNC; + } + else + return FUNC; +} + +static I32 +sublex_push() +{ push_scope(); - SAVEINT(lex_dojoin); - SAVEINT(lex_brackets); - SAVEINT(lex_fakebrack); - SAVEINT(lex_casemods); - SAVEINT(lex_starts); - SAVEINT(lex_state); + + lex_state = sublex_info.super_state; + SAVEI32(lex_dojoin); + SAVEI32(lex_brackets); + SAVEI32(lex_fakebrack); + SAVEI32(lex_casemods); + SAVEI32(lex_starts); + SAVEI32(lex_state); SAVESPTR(lex_inpat); - SAVEINT(lex_inwhat); - SAVEINT(curcop->cop_line); + SAVEI32(lex_inwhat); + SAVEI16(curcop->cop_line); SAVEPPTR(bufptr); SAVEPPTR(oldbufptr); SAVEPPTR(oldoldbufptr); + SAVEPPTR(linestart); SAVESPTR(linestr); SAVEPPTR(lex_brackstack); SAVEPPTR(lex_casestack); @@ -572,7 +660,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); @@ -589,21 +677,13 @@ sublex_start() lex_state = LEX_INTERPCONCAT; curcop->cop_line = multi_start; - lex_inwhat = op_type; - if (op_type == OP_MATCH || op_type == OP_SUBST) - lex_inpat = lex_op; + lex_inwhat = sublex_info.sub_inwhat; + if (lex_inwhat == OP_MATCH || lex_inwhat == OP_SUBST) + lex_inpat = sublex_info.sub_op; else - lex_inpat = 0; + lex_inpat = Nullop; - expect = XTERM; - force_next('('); - if (lex_op) { - yylval.opval = lex_op; - lex_op = Nullop; - return PMFUNC; - } - else - return FUNC; + return '('; } static I32 @@ -624,7 +704,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; @@ -677,8 +757,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; @@ -745,10 +825,8 @@ char *start; continue; case 'c': s++; - *d = *s++; - if (isLOWER(*d)) - *d = toUPPER(*d); - *d++ ^= 64; + len = *s++; + *d++ = toCTRL(len); continue; case 'b': *d++ = '\b'; @@ -935,7 +1013,7 @@ GV *gv; if (gv) { if (GvIO(gv)) return 0; - if (!GvCV(gv)) + if (!GvCVu(gv)) gv = 0; } s = scan_word(s, tmpbuf, TRUE, &len); @@ -949,11 +1027,13 @@ GV *gv; } if (!keyword(tmpbuf, len)) { indirgv = gv_fetchpv(tmpbuf,FALSE, SVt_PVCV); - if (indirgv && GvCV(indirgv)) + if (indirgv && GvCVu(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); + if ((bufend - s) >= 2 && *s == '=' && *(s+1) == '>') + return 0; /* no assumptions -- "=>" quotes bearword */ nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tmpbuf,0)); @@ -982,15 +1062,145 @@ incl_perldb() } -/* Encrypted script support: cryptswitch_add() may be called to */ -/* define a function which may manipulate the input stream */ -/* (via popen() etc) to decode the input if required. */ -/* At the moment we only allow one cryptswitch function. */ +/* Encoded script support. filter_add() effectively inserts a + * 'pre-processing' function into the current source input stream. + * Note that the filter function only applies to the current source file + * (e.g., it will not affect files 'require'd or 'use'd by this one). + * + * The datasv parameter (which may be NULL) can be used to pass + * private data to this instance of the filter. The filter function + * can recover the SV using the FILTER_DATA macro and use it to + * store private buffers and state information. + * + * The supplied datasv parameter is upgraded to a PVIO type + * and the IoDIRP field is used to store the function pointer. + * Note that IoTOP_NAME, IoFMT_NAME, IoBOTTOM_NAME, if set for + * private use must be set using malloc'd pointers. + */ +static int filter_debug = 0; + +SV * +filter_add(funcp, datasv) + filter_t funcp; + SV *datasv; +{ + if (!funcp){ /* temporary handy debugging hack to be deleted */ + filter_debug = atoi((char*)datasv); + return NULL; + } + if (!rsfp_filters) + rsfp_filters = newAV(); + if (!datasv) + datasv = newSV(0); + if (!SvUPGRADE(datasv, SVt_PVIO)) + die("Can't upgrade filter_add data to SVt_PVIO"); + IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */ + if (filter_debug) + warn("filter_add func %lx (%s)", funcp, SvPV(datasv,na)); + av_unshift(rsfp_filters, 1); + av_store(rsfp_filters, 0, datasv) ; + return(datasv); +} + + +/* Delete most recently added instance of this filter function. */ void -cryptswitch_add(funcp) - cryptswitch_t funcp; +filter_del(funcp) + filter_t funcp; { - cryptswitch_fp = funcp; + if (filter_debug) + warn("filter_del func %lx", 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(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 */ + die("filter_del can only delete in reverse order (currently)"); +} + + +/* Invoke the n'th filter function for the current rsfp. */ +I32 +filter_read(idx, buf_sv, maxlen) + int idx; + SV *buf_sv; + int maxlen; /* 0 = read one text line */ +{ + 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. */ + if (filter_debug) + warn("filter_read %d: from rsfp\n", idx); + if (maxlen) { + /* Want a block */ + int len ; + int old_len = SvCUR(buf_sv) ; + + /* ensure buf_sv is large enough */ + SvGROW(buf_sv, old_len + maxlen) ; + 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)) == NULL) { + if (PerlIO_error(rsfp)) + return -1; /* error */ + else + return 0 ; /* end of file */ + } + } + return SvCUR(buf_sv); + } + /* Skip this filter slot if filter has been deleted */ + if ( (datasv = FILTER_DATA(idx)) == &sv_undef){ + if (filter_debug) + warn("filter_read %d: skipped (filter deleted)\n", idx); + return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */ + } + /* Get function pointer hidden within datasv */ + funcp = (filter_t)IoDIRP(datasv); + if (filter_debug) + warn("filter_read %d: via function %lx (%s)\n", + idx, funcp, SvPV(datasv,na)); + /* 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)(idx, buf_sv, maxlen); +} + +static char * +filter_gets(sv,fp, append) +register SV *sv; +register PerlIO *fp; +STRLEN append; +{ + if (rsfp_filters) { + + if (!append) + SvCUR_set(sv, 0); /* start with empty line */ + if (FILTER_READ(0, sv, 0) > 0) + return ( SvPVX(sv) ) ; + else + return Nullch ; + } + else + return (sv_gets(sv, fp, append)); + } @@ -999,7 +1209,7 @@ cryptswitch_add(funcp) { "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "TERMBLOCK" }; #endif -extern int yychar; /* last token */ +EXT int yychar; /* last token */ int yylex() @@ -1009,6 +1219,59 @@ yylex() register I32 tmp; STRLEN len; + if (pending_ident) { + char pit = pending_ident; + pending_ident = 0; + + if (in_my) { + if (strchr(tokenbuf,':')) + croak(no_myglob,tokenbuf); + yylval.opval = newOP(OP_PADANY, 0); + yylval.opval->op_targ = pad_allocmy(tokenbuf); + return PRIVATEREF; + } + + if (!strchr(tokenbuf,':') && (tmp = pad_findmy(tokenbuf))) { + if (last_lop_op == OP_SORT && + tokenbuf[0] == '$' && + (tokenbuf[1] == 'a' || tokenbuf[1] == 'b') + && !tokenbuf[2]) + { + 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); + } + } + } + + yylval.opval = newOP(OP_PADANY, 0); + yylval.opval->op_targ = tmp; + return PRIVATEREF; + } + + /* Force them to make up their mind on "@foo". */ + if (pit == '@' && lex_state != LEX_NORMAL && !lex_brackets) { + GV *gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV); + if (!gv || ((tokenbuf[0] == '@') ? !GvAV(gv) : !GvHV(gv))) { + char tmpbuf[1024]; + sprintf(tmpbuf, "Literal %s now requires backslash", tokenbuf); + yyerror(tmpbuf); + } + } + + yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf+1, 0)); + yylval.opval->op_private = OPpCONST_ENTERED; + gv_fetchpv(tokenbuf+1, in_eval ? GV_ADDMULTI : TRUE, + ((tokenbuf[0] == '$') ? SVt_PV + : (tokenbuf[0] == '@') ? SVt_PVAV + : SVt_PVHV)); + return WORD; + } + switch (lex_state) { #ifdef COMMENTARY case LEX_NORMAL: /* Some compilers will produce faster */ @@ -1058,7 +1321,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; @@ -1092,6 +1355,9 @@ yylex() return yylex(); } + case LEX_INTERPPUSH: + return sublex_push(); + case LEX_INTERPSTART: if (bufptr == bufend) return sublex_done(); @@ -1179,7 +1445,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: @@ -1192,6 +1458,8 @@ yylex() goto fake_eof; /* emulate EOF on ^D or ^Z */ case 0: if (!rsfp) { + last_uni = 0; + last_lop = 0; if (lex_brackets) yyerror("Missing right bracket"); TOKEN(0); @@ -1203,8 +1471,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) @@ -1225,7 +1503,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); @@ -1236,35 +1514,27 @@ yylex() } goto retry; } - /* Give cryptswitch a chance. Note that cryptswitch_fp may */ - /* be either be called once if it redirects rsfp and unregisters */ - /* itself, or it may be called on every line if it loads linestr. */ - if (cryptswitch_fp && (*cryptswitch_fp)()) { - oldoldbufptr = oldbufptr = s = SvPVX(linestr); - bufend = SvPVX(linestr) + SvCUR(linestr); - goto retry; - } do { - if ((s = sv_gets(linestr, rsfp, 0)) == 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 */ } @@ -1275,14 +1545,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); @@ -1296,11 +1566,78 @@ yylex() s++; if (*s == ':' && s[1] != ':') /* for csh execing sh scripts */ s++; - if (!in_eval && *s == '#' && s[1] == '!') { + d = Nullch; + if (!in_eval) { + if (*s == '#' && *(s+1) == '!') + d = s + 2; +#ifdef ALTERNATE_SHEBANG + else { + static char as[] = ALTERNATE_SHEBANG; + if (*s == as[0] && strnEQ(s, as, sizeof(as) - 1)) + d = s + (sizeof(as) - 1); + } +#endif /* ALTERNATE_SHEBANG */ + } + if (d) { + /* + * HP-UX (at least) sets argv[0] to the script name, + * which makes $^X incorrect. And Digital UNIX and Linux, + * 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)); + char *ipath; + char *ibase; + + while (*d == ' ' || *d == '\t') + d++; + ipath = d; + ibase = Nullch; + while (*d && !isSPACE(*d)) { + if (*d++ == '/') + ibase = d; + } + assert(SvPOK(x) || SvGMAGICAL(x)); + if (sv_eq(x, GvSV(curcop->cop_filegv)) + || (ibase + && SvCUR(x) == (d - ibase) + && strnEQ(SvPVX(x), ibase, d - ibase))) + sv_setpvn(x, ipath, d - ipath); + /* + * $^X is always tainted, but taintedness must be off + * when parsing code, so forget we ever saw it. + */ + TAINT_NOT; + + /* + * Look for options. + */ d = instr(s,"perl -"); if (!d) d = instr(s,"perl"); +#ifdef ALTERNATE_SHEBANG + /* + * If the ALTERNATE_SHEBANG on this system starts with a + * character that can be part of a Perl expression, then if + * we see it but not "perl", we're probably looking at the + * start of Perl code, not a request to hand off to some + * other interpreter. Similarly, if "perl" is there, but + * not in the first 'word' of the line, we assume the line + * contains the start of the Perl program. + * This isn't foolproof, but it's generally a good guess. + */ + if (d && *s != '#') { + char *c = s; + while (*c && !strchr("; \t\r\n\f\v#", *c)) + c++; + if (c < d) + d = Nullch; /* "perl" not in first word; ignore */ + else + *s = '#'; /* Don't try to parse shebang line */ + } +#endif if (!d && + *s == '#' && !minus_c && !instr(s,"indir") && instr(origargv[0],"perl")) @@ -1337,16 +1674,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) @@ -1499,35 +1837,19 @@ yylex() Mop(OP_MULTIPLY); case '%': - if (expect != XOPERATOR) { - s = scan_ident(s, bufend, tokenbuf + 1, TRUE); - if (tokenbuf[1]) { - expect = XOPERATOR; - tokenbuf[0] = '%'; - if (in_my) { - if (strchr(tokenbuf,':')) - croak(no_myglob,tokenbuf); - nextval[nexttoke].opval = newOP(OP_PADANY, 0); - nextval[nexttoke].opval->op_targ = pad_allocmy(tokenbuf); - force_next(PRIVATEREF); - TERM('%'); - } - if (!strchr(tokenbuf,':')) { - if (tmp = pad_findmy(tokenbuf)) { - nextval[nexttoke].opval = newOP(OP_PADANY, 0); - nextval[nexttoke].opval->op_targ = tmp; - force_next(PRIVATEREF); - TERM('%'); - } - } - force_ident(tokenbuf + 1, *tokenbuf); - } - else - PREREF('%'); - TERM('%'); + if (expect == XOPERATOR) { + ++s; + Mop(OP_MODULO); } - ++s; - Mop(OP_MODULO); + tokenbuf[0] = '%'; + s = scan_ident(s, bufend, tokenbuf+1, TRUE); + if (!tokenbuf[1]) { + if (s == bufend) + yyerror("Final % should be \\% or %name"); + PREREF('%'); + } + pending_ident = '%'; + TERM('%'); case '^': s++; @@ -1560,6 +1882,9 @@ yylex() OPERATOR(tmp); case ')': tmp = *s++; + s = skipspace(s); + if (*s == '{') + PREBLOCK(tmp); TERM(tmp); case ']': s++; @@ -1573,12 +1898,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; @@ -1599,17 +1924,29 @@ yylex() case XOPERATOR: while (s < bufend && (*s == ' ' || *s == '\t')) s++; - if (s < bufend && isALPHA(*s)) { - d = scan_word(s, tokenbuf, FALSE, &len); + d = s; + tokenbuf[0] = '\0'; + if (d < bufend && *d == '-') { + tokenbuf[0] = '-'; + d++; + while (d < bufend && (*d == ' ' || *d == '\t')) + d++; + } + if (d < bufend && isIDFIRST(*d)) { + d = scan_word(d, tokenbuf + 1, FALSE, &len); while (d < bufend && (*d == ' ' || *d == '\t')) d++; if (*d == '}') { + char minus = (tokenbuf[0] == '-'); if (dowarn && - (keyword(tokenbuf, len) || - perl_get_cv(tokenbuf, FALSE) )) + (keyword(tokenbuf + 1, len) || + (minus && len == 1 && isALPHA(tokenbuf[1])) || + perl_get_cv(tokenbuf + 1, FALSE) )) warn("Ambiguous use of {%s} resolved to {\"%s\"}", - tokenbuf, tokenbuf); - s = force_word(s,WORD,FALSE,TRUE,FALSE); + tokenbuf + !minus, tokenbuf + !minus); + s = force_word(s + minus, WORD, FALSE, TRUE, FALSE); + if (minus) + force_next('-'); } } /* FALL THROUGH */ @@ -1631,7 +1968,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); @@ -1673,7 +2010,9 @@ yylex() bufptr = s; return yylex(); /* ignore fake brackets */ } - if (*s != '[' && *s != '{' && (*s != '-' || s[1] != '>')) + if (*s == '-' && s[1] == '>') + lex_state = LEX_INTERPENDMAYBE; + else if (*s != '[' && *s != '{') lex_state = LEX_INTERPEND; } } @@ -1691,7 +2030,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++; @@ -1706,6 +2045,7 @@ yylex() } else PREREF('&'); + yylval.ival = (OPpENTERSUB_AMPER<<8); TERM('&'); case '|': @@ -1728,8 +2068,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; @@ -1788,67 +2146,72 @@ yylex() Rop(OP_GT); case '$': - if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) { - s = scan_ident(s+1, bufend, tokenbuf+1, FALSE); - if (expect == XOPERATOR) { - if (lex_formbrack && lex_brackets == lex_formbrack) { - expect = XTERM; - depcom(); - return ','; /* grandfather non-comma-format format */ - } - else - no_op("Array length",s); + CLINE; + + if (expect == XOPERATOR) { + if (lex_formbrack && lex_brackets == lex_formbrack) { + expect = XTERM; + depcom(); + return ','; /* grandfather non-comma-format format */ } - else if (!tokenbuf[1]) + } + + if (s[1] == '#' && (isALPHA(s[2]) || strchr("_{$:", s[2]))) { + if (expect == XOPERATOR) + no_op("Array length", bufptr); + tokenbuf[0] = '@'; + s = scan_ident(s+1, bufend, tokenbuf+1, FALSE); + if (!tokenbuf[1]) PREREF(DOLSHARP); - if (!strchr(tokenbuf+1,':')) { - tokenbuf[0] = '@'; - if (tmp = pad_findmy(tokenbuf)) { - nextval[nexttoke].opval = newOP(OP_PADANY, 0); - nextval[nexttoke].opval->op_targ = tmp; - expect = XOPERATOR; - force_next(PRIVATEREF); - TOKEN(DOLSHARP); - } - } expect = XOPERATOR; - force_ident(tokenbuf+1, *tokenbuf); + pending_ident = '#'; TOKEN(DOLSHARP); } + + if (expect == XOPERATOR) + no_op("Scalar", bufptr); + tokenbuf[0] = '$'; s = scan_ident(s, bufend, tokenbuf+1, FALSE); - if (expect == XOPERATOR) { - if (lex_formbrack && lex_brackets == lex_formbrack) { - expect = XTERM; - depcom(); - return ','; /* grandfather non-comma-format format */ - } - else - no_op("Scalar",s); + if (!tokenbuf[1]) { + if (s == bufend) + yyerror("Final $ should be \\$ or $name"); + PREREF('$'); } - if (tokenbuf[1]) { - expectation oldexpect = expect; - /* This kludge not intended to be bulletproof. */ - if (tokenbuf[1] == '[' && !tokenbuf[2]) { - yylval.opval = newSVOP(OP_CONST, 0, - newSViv((IV)compiling.cop_arybase)); - yylval.opval->op_private = OPpCONST_ARYBASE; - TERM(THING); - } - tokenbuf[0] = '$'; - if (dowarn) { - char *t; - if (*s == '[' && oldexpect != XREF) { - for (t = s+1; isSPACE(*t) || isALNUM(*t) || *t == '$'; t++) ; + /* This kludge not intended to be bulletproof. */ + if (tokenbuf[1] == '[' && !tokenbuf[2]) { + yylval.opval = newSVOP(OP_CONST, 0, + newSViv((IV)compiling.cop_arybase)); + yylval.opval->op_private = OPpCONST_ARYBASE; + TERM(THING); + } + + d = s; + if (lex_state == LEX_NORMAL) + s = skipspace(s); + + if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) { + char *t; + if (*s == '[') { + tokenbuf[0] = '@'; + if (dowarn) { + for(t = s + 1; + isSPACE(*t) || isALNUM(*t) || *t == '$'; + t++) ; if (*t++ == ',') { bufptr = skipspace(bufptr); - while (t < bufend && *t != ']') t++; + while (t < bufend && *t != ']') + t++; warn("Multidimensional syntax %.*s not supported", - t-bufptr+1, bufptr); + (t - bufptr) + 1, bufptr); } } - if (*s == '{' && strEQ(tokenbuf, "$SIG") && - (t = strchr(s,'}')) && (t = strchr(t,'='))) { + } + else if (*s == '{') { + tokenbuf[0] = '%'; + if (dowarn && strEQ(tokenbuf+1, "SIG") && + (t = strchr(s, '}')) && (t = strchr(t, '='))) + { char tmpbuf[1024]; STRLEN len; for (t++; isSPACE(*t); t++) ; @@ -1859,103 +2222,44 @@ yylex() } } } - expect = XOPERATOR; - if (lex_state == LEX_NORMAL && isSPACE(*s)) { - bool islop = (last_lop == oldoldbufptr); - s = skipspace(s); - if (!islop || last_lop_op == OP_GREPSTART) - expect = XOPERATOR; - else if (strchr("$@\"'`q", *s)) - expect = XTERM; /* e.g. print $fh "foo" */ - else if (strchr("&*<%", *s) && isIDFIRST(s[1])) - expect = XTERM; /* e.g. print $fh &sub */ - else if (isDIGIT(*s)) - expect = XTERM; /* e.g. print $fh 3 */ - else if (*s == '.' && isDIGIT(s[1])) - expect = XTERM; /* e.g. print $fh .3 */ - else if (strchr("/?-+", *s) && !isSPACE(s[1])) - expect = XTERM; /* e.g. print $fh -1 */ - else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])) - expect = XTERM; /* print $fh <<"EOF" */ - } - if (in_my) { - if (strchr(tokenbuf,':')) - croak(no_myglob,tokenbuf); - nextval[nexttoke].opval = newOP(OP_PADANY, 0); - nextval[nexttoke].opval->op_targ = pad_allocmy(tokenbuf); - force_next(PRIVATEREF); - } - else if (!strchr(tokenbuf,':')) { - if (oldexpect != XREF || oldoldbufptr == last_lop) { - if (*s == '[') - tokenbuf[0] = '@'; - else if (*s == '{') - tokenbuf[0] = '%'; - } - if (tmp = pad_findmy(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*/ - force_ident(tokenbuf+1, *tokenbuf); - } - } - else - force_ident(tokenbuf+1, *tokenbuf); } - else { - if (s == bufend) - yyerror("Final $ should be \\$ or $name"); - PREREF('$'); + + expect = XOPERATOR; + if (lex_state == LEX_NORMAL && isSPACE(*d)) { + bool islop = (last_lop == oldoldbufptr); + if (!islop || last_lop_op == OP_GREPSTART) + expect = XOPERATOR; + else if (strchr("$@\"'`q", *s)) + expect = XTERM; /* e.g. print $fh "foo" */ + else if (strchr("&*<%", *s) && isIDFIRST(s[1])) + expect = XTERM; /* e.g. print $fh &sub */ + else if (isDIGIT(*s)) + expect = XTERM; /* e.g. print $fh 3 */ + else if (*s == '.' && isDIGIT(s[1])) + expect = XTERM; /* e.g. print $fh .3 */ + else if (strchr("/?-+", *s) && !isSPACE(s[1])) + expect = XTERM; /* e.g. print $fh -1 */ + else if (*s == '<' && s[1] == '<' && !isSPACE(s[2])) + expect = XTERM; /* print $fh <<"EOF" */ } + pending_ident = '$'; TOKEN('$'); case '@': - s = scan_ident(s, bufend, tokenbuf+1, FALSE); if (expect == XOPERATOR) - no_op("Array",s); - if (tokenbuf[1]) { - GV* gv; - - tokenbuf[0] = '@'; - expect = XOPERATOR; - if (in_my) { - if (strchr(tokenbuf,':')) - croak(no_myglob,tokenbuf); - nextval[nexttoke].opval = newOP(OP_PADANY, 0); - nextval[nexttoke].opval->op_targ = pad_allocmy(tokenbuf); - force_next(PRIVATEREF); - TERM('@'); - } - else if (!strchr(tokenbuf,':')) { - if (*s == '{') - tokenbuf[0] = '%'; - if (tmp = pad_findmy(tokenbuf)) { - nextval[nexttoke].opval = newOP(OP_PADANY, 0); - nextval[nexttoke].opval->op_targ = tmp; - force_next(PRIVATEREF); - TERM('@'); - } - } - - /* Force them to make up their mind on "@foo". */ - if (lex_state != LEX_NORMAL && - ( !(gv = gv_fetchpv(tokenbuf+1, FALSE, SVt_PVAV)) || - (*tokenbuf == '@' - ? !GvAV(gv) - : !GvHV(gv) ))) - { - char tmpbuf[1024]; - sprintf(tmpbuf, "Literal @%s now requires backslash",tokenbuf+1); - yyerror(tmpbuf); - } + no_op("Array", s); + tokenbuf[0] = '@'; + s = scan_ident(s, bufend, tokenbuf+1, FALSE); + if (!tokenbuf[1]) { + if (s == bufend) + yyerror("Final @ should be \\@ or @name"); + PREREF('@'); + } + if (lex_state == LEX_NORMAL) + s = skipspace(s); + if ((expect != XREF || oldoldbufptr == last_lop) && intuit_more(s)) { + if (*s == '{') + tokenbuf[0] = '%'; /* Warn about @ where they meant $. */ if (dowarn) { @@ -1971,13 +2275,8 @@ yylex() } } } - force_ident(tokenbuf+1, *tokenbuf); - } - else { - if (s == bufend) - yyerror("Final @ should be \\@ or @name"); - PREREF('@'); } + pending_ident = '@'; TERM('@'); case '/': /* may either be division or pattern */ @@ -1994,7 +2293,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; @@ -2052,7 +2351,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 '`': @@ -2111,13 +2416,34 @@ yylex() keylookup: bufptr = s; s = scan_word(s, tokenbuf, FALSE, &len); - - tmp = keyword(tokenbuf, len); - /* Is this a word before a => operator? */ + /* Some keywords can be followed by any delimiter, including ':' */ + tmp = (len == 1 && strchr("msyq", tokenbuf[0]) || + len == 2 && ((tokenbuf[0] == 't' && tokenbuf[1] == 'r') || + (tokenbuf[0] == 'q' && + strchr("qwx", tokenbuf[1])))); + + /* x::* is just a word, unless x is "CORE" */ + if (!tmp && *s == ':' && s[1] == ':' && strNE(tokenbuf, "CORE")) + goto just_a_word; + d = s; - while (d < bufend && (*d == ' ' || *d == '\t')) + while (d < bufend && isSPACE(*d)) d++; /* no comments skipped here, or s### is misparsed */ + + /* Is this a label? */ + if (!tmp && expect == XSTATE + && d < bufend && *d == ':' && *(d + 1) != ':') { + s = d + 1; + yylval.pval = savepv(tokenbuf); + CLINE; + TOKEN(LABEL); + } + + /* Check for keywords */ + tmp = keyword(tokenbuf, len); + + /* Is this a word before a => operator? */ if (strnEQ(d,"=>",2)) { CLINE; if (dowarn && (tmp || perl_get_cv(tokenbuf, FALSE))) @@ -2131,10 +2457,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; } @@ -2158,19 +2483,8 @@ yylex() croak("Bad name after %s::", tokenbuf); } - /* Do special processing at start of statement. */ - - if (expect == XSTATE) { - while (isSPACE(*s)) s++; - if (*s == ':') { /* It's a label. */ - yylval.pval = savepv(tokenbuf); - s++; - CLINE; - TOKEN(LABEL); - } - } - else if (expect == XOPERATOR) { - if (bufptr == SvPVX(linestr)) { + if (expect == XOPERATOR) { + if (bufptr == linestart) { curcop->cop_line--; warn(warn_nosemi); curcop->cop_line++; @@ -2211,8 +2525,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 || !GvCVu(gv))) ) && + (last_lop_op != OP_MAPSTART && last_lop_op != OP_GREPSTART)){ expect = (last_lop == oldoldbufptr) ? XTERM : XOPERATOR; goto bareword; } @@ -2227,12 +2542,13 @@ yylex() nextval[nexttoke].opval = yylval.opval; expect = XOPERATOR; force_next(WORD); + yylval.ival = 0; TOKEN('&'); } /* If followed by var or block, call it a method (unless sub) */ - if ((*s == '$' || *s == '{') && (!gv || !GvCV(gv))) { + if ((*s == '$' || *s == '{') && (!gv || !GvCVu(gv))) { last_lop = oldbufptr; last_lop_op = OP_METHOD; PREBLOCK(METHOD); @@ -2245,18 +2561,48 @@ yylex() /* Not a method, so call it a subroutine (if defined) */ - if (gv && GvCV(gv)) { - nextval[nexttoke].opval = yylval.opval; + if (gv && GvCVu(gv)) { + 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); @@ -2265,6 +2611,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) @@ -2288,7 +2635,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); @@ -2304,25 +2651,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)) = '<'; @@ -2513,10 +2868,16 @@ yylex() case KEY_for: case KEY_foreach: yylval.ival = curcop->cop_line; - while (s < bufend && isSPACE(*s)) - s++; - if (isIDFIRST(*s)) - croak("Missing $ on loop variable"); + s = skipspace(s); + if (isIDFIRST(*s)) { + char *p = s; + if ((bufend - p) >= 3 && + strnEQ(p, "my", 2) && isSPACE(*(p + 2))) + p += 2; + p = skipspace(p); + if (isIDFIRST(*p)) + croak("Missing $ on loop variable"); + } OPERATOR(FOR); case KEY_formline: @@ -2575,10 +2936,10 @@ yylex() FUN0(OP_GPWENT); case KEY_getpwnam: - FUN1(OP_GPWNAM); + UNI(OP_GPWNAM); case KEY_getpwuid: - FUN1(OP_GPWUID); + UNI(OP_GPWUID); case KEY_getpeername: UNI(OP_GETPEERNAME); @@ -2620,10 +2981,10 @@ yylex() FUN0(OP_GGRENT); case KEY_getgrnam: - FUN1(OP_GGRNAM); + UNI(OP_GGRNAM); case KEY_getgrgid: - FUN1(OP_GGRGID); + UNI(OP_GGRGID); case KEY_getlogin: FUN0(OP_GETLOGIN); @@ -2668,7 +3029,6 @@ yylex() UNI(OP_LCFIRST); case KEY_local: - yylval.ival = 0; OPERATOR(LOCAL); case KEY_length: @@ -2719,8 +3079,7 @@ yylex() case KEY_my: in_my = TRUE; - yylval.ival = 1; - OPERATOR(LOCAL); + OPERATOR(MY); case KEY_next: s = force_word(s,WORD,TRUE,FALSE,FALSE); @@ -2733,6 +3092,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); @@ -2772,6 +3132,9 @@ yylex() checkcomma(s,tokenbuf,"filehandle"); LOP(OP_PRTF,XREF); + case KEY_prototype: + UNI(OP_PROTOTYPE); + case KEY_push: LOP(OP_PUSH,XTERM); @@ -2805,6 +3168,19 @@ yylex() s = scan_str(s); if (!s) missingterm((char*)0); + if (dowarn && SvLEN(lex_stuff)) { + d = SvPV_force(lex_stuff, len); + for (; len; --len, ++d) { + if (*d == ',') { + warn("Possible attempt to separate words with commas"); + break; + } + if (*d == '#') { + warn("Possible attempt to put comments in qw() list"); + break; + } + } + } force_next(')'); nextval[nexttoke].opval = (OP*)newSVOP(OP_CONST, 0, q(lex_stuff)); lex_stuff = Nullsv; @@ -2845,7 +3221,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); @@ -2936,16 +3312,16 @@ yylex() LOP(OP_SETPRIORITY,XTERM); case KEY_sethostent: - FUN1(OP_SHOSTENT); + UNI(OP_SHOSTENT); case KEY_setnetent: - FUN1(OP_SNETENT); + UNI(OP_SNETENT); case KEY_setservent: - FUN1(OP_SSERVENT); + UNI(OP_SSERVENT); case KEY_setprotoent: - FUN1(OP_SPROTOENT); + UNI(OP_SPROTOENT); case KEY_setpwent: FUN0(OP_SPWENT); @@ -3027,13 +3403,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); @@ -3043,17 +3416,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(); @@ -3065,6 +3468,9 @@ yylex() case KEY_syscall: LOP(OP_SYSCALL,XTERM); + case KEY_sysopen: + LOP(OP_SYSOPEN,XTERM); + case KEY_sysread: LOP(OP_SYSREAD,XTERM); @@ -3084,6 +3490,9 @@ yylex() case KEY_tie: LOP(OP_TIE,XTERM); + case KEY_tied: + UNI(OP_TIED); + case KEY_time: FUN0(OP_TIME); @@ -3136,7 +3545,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); @@ -3195,6 +3615,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; @@ -3309,6 +3730,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; @@ -3554,6 +3976,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': @@ -3696,6 +4120,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; @@ -3717,6 +4142,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: @@ -3827,7 +4253,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; @@ -3921,20 +4347,26 @@ I32 ck_uni; *d = *s++; d[1] = '\0'; if (*d == '^' && *s && (isUPPER(*s) || strchr("[\\]^_?", *s))) { - *d = *s++ ^ 64; + *d = toCTRL(*s); + s++; } if (bracket) { if (isSPACE(s[-1])) { - while (s < send && (*s == ' ' || *s == '\t')) s++; - *d = *s; + while (s < send) { + char ch = *s++; + if (ch != ' ' && ch != '\t') { + *d = ch; + break; + } + } } - if (isALPHA(*d) || *d == '_') { + if (isIDFIRST(*d)) { d++; while (isALNUM(*s) || *s == ':') *d++ = *s++; *d = '\0'; while (s < send && (*s == ' ' || *s == '\t')) s++; - if ((*s == '[' || *s == '{')) { + if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { if (dowarn && keyword(dest, d - dest)) { char *brack = *s == '[' ? "[...]" : "{...}"; warn("Ambiguous use of %c{%s%s} resolved to %c%s%s", @@ -3971,10 +4403,8 @@ void pmflag(pmfl,ch) U16* pmfl; int ch; { - if (ch == 'i') { - sawi = TRUE; + if (ch == 'i') *pmfl |= PMf_FOLD; - } else if (ch == 'g') *pmfl |= PMf_GLOBAL; else if (ch == 'o') @@ -4001,12 +4431,13 @@ char *start; lex_stuff = Nullsv; croak("Search pattern not terminated"); } + pm = (PMOP*)newPMOP(OP_MATCH, 0); if (multi_open == '?') pm->op_pmflags |= PMf_ONCE; - while (*s && strchr("iogmsx", *s)) pmflag(&pm->op_pmflags,*s++); + pm->op_pmpermflags = pm->op_pmflags; lex_op = (OP*)pm; yylval.ival = OP_MATCH; @@ -4070,6 +4501,7 @@ char *start; lex_repl = repl; } + pm->op_pmpermflags = pm->op_pmflags; lex_op = (OP*)pm; yylval.ival = OP_SUBST; return s; @@ -4084,8 +4516,6 @@ register PMOP *pm; ) { if (!(pm->op_pmregexp->reganch & ROPT_ANCH)) pm->op_pmflags |= PMf_SCANFIRST; - else if (pm->op_pmflags & PMf_FOLD) - return; pm->op_pmshort = SvREFCNT_inc(pm->op_pmregexp->regstart); pm->op_pmslen = SvCUR(pm->op_pmshort); } @@ -4179,12 +4609,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) @@ -4196,6 +4629,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 */ @@ -4227,7 +4662,7 @@ register char *s; if (!rsfp) { d = s; while (s < bufend && - (*s != term || bcmp(s,tokenbuf,len) != 0) ) { + (*s != term || memNE(s,tokenbuf,len)) ) { if (*s++ == '\n') curcop->cop_line++; } @@ -4239,14 +4674,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 = sv_gets(linestr, rsfp, 0))) { + !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) { curcop->cop_line = multi_start; missingterm(tokenbuf); } @@ -4260,7 +4695,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 && memEQ(s,tokenbuf,len)) { s = bufend - 1; *s = ' '; sv_catsv(linestr,herewas); @@ -4298,7 +4733,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) { @@ -4405,7 +4840,8 @@ char *start; if (s < bufend) break; /* string ends on this line? */ if (!rsfp || - !(oldoldbufptr = oldbufptr = s = sv_gets(linestr, rsfp, 0))) { + !(oldoldbufptr = oldbufptr = s = linestart = filter_gets(linestr, rsfp, 0))) { + sv_free(sv); curcop->cop_line = multi_start; return Nullch; } @@ -4450,8 +4886,9 @@ char *start; croak("panic: scan_num"); case '0': { - U32 i; + UV u; I32 shift; + bool overflowed = FALSE; if (s[1] == 'x') { shift = 4; @@ -4461,8 +4898,10 @@ char *start; goto decimal; else shift = 3; - i = 0; + u = 0; for (;;) { + UV n, b; + switch (*s) { default: goto out; @@ -4475,25 +4914,27 @@ char *start; /* FALL THROUGH */ case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': - i <<= shift; - i += *s++ & 15; - break; + b = *s++ & 15; + goto digit; case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': if (shift != 4) goto out; - i <<= 4; - i += (*s++ & 7) + 9; + b = (*s++ & 7) + 9; + digit: + n = u << shift; + if (!overflowed && (n >> shift) != u) { + warn("Integer overflow in %s number", + (shift == 4) ? "hex" : "octal"); + overflowed = TRUE; + } + u = n | b; break; } } out: sv = NEWSV(92,0); - tryi32 = i; - if (tryi32 == i && tryi32 >= 0) - sv_setiv(sv,tryi32); - else - sv_setnv(sv,(double)i); + sv_setuv(sv, u); } break; case '1': case '2': case '3': case '4': case '5': @@ -4533,6 +4974,7 @@ char *start; } *d = '\0'; sv = NEWSV(92,0); + SET_NUMERIC_STANDARD(); value = atof(tokenbuf); tryi32 = I_32(value); if (!floatit && (double)tryi32 == value) @@ -4583,8 +5025,8 @@ register char *s; } s = eol; if (rsfp) { - s = sv_gets(linestr, rsfp, 0); - 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; @@ -4627,31 +5069,34 @@ set_csh() } int -start_subparse() +start_subparse(flags) +U32 flags; { int oldsavestack_ix = savestack_ix; CV* outsidecv = compcv; AV* comppadlist; + if (compcv) { + assert(SvTYPE(compcv) == SVt_PVCV); + } save_I32(&subline); save_item(subname); - SAVEINT(padix); + SAVEI32(padix); SAVESPTR(curpad); SAVESPTR(comppad); SAVESPTR(comppad_name); SAVESPTR(compcv); - SAVEINT(comppad_name_fill); - SAVEINT(min_intro_pending); - SAVEINT(max_intro_pending); - SAVEINT(pad_reset_pending); + SAVEI32(comppad_name_fill); + SAVEI32(min_intro_pending); + SAVEI32(max_intro_pending); + SAVEI32(pad_reset_pending); compcv = (CV*)NEWSV(1104,0); - sv_upgrade((SV *)compcv, SVt_PVCV); + sv_upgrade((SV *)compcv, (flags & CVf_FORMAT) ? SVt_PVFM : SVt_PVCV); + CvFLAGS(compcv) |= flags; comppad = newAV(); - SAVEFREESV((SV*)comppad); comppad_name = newAV(); - SAVEFREESV((SV*)comppad_name); comppad_name_fill = 0; min_intro_pending = 0; av_push(comppad, Nullsv); @@ -4661,11 +5106,11 @@ 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) = outsidecv; + CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc((SV*)outsidecv); return oldsavestack_ix; } @@ -4708,11 +5153,13 @@ 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"); } else if (yychar < 32) - (void)sprintf(tname,"next char ^%c",yychar+64); + (void)sprintf(tname,"next char ^%c",toCTRL(yychar)); else (void)sprintf(tname,"next char %c",yychar); (void)sprintf(buf, "%s at %s line %d, %s\n", @@ -4726,11 +5173,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; }