X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=c6d56edb5c7ce7e602aead94f1724e6a66d9153e;hb=d83e3bda142ab17f4cd2633e1fb9f48644dabcbf;hp=7bb61c959767d0557d3a089ce48d7f4849567f88;hpb=a5f75d667838e8e7bb037880391f5c44476d33b4;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/toke.c b/toke.c
index 7bb61c9..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,9 +44,11 @@ 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).
  */
@@ -68,6 +71,12 @@ static void restore_rsfp _((void *f));
 #include <sys/file.h>
 #endif
 
+/* XXX If this causes problems, set i_unistd=undef in the hint file.  */
+#ifdef I_UNISTD
+#  include <unistd.h> /* Needed for execv() */
+#endif
+
+
 #ifdef ff_next
 #undef ff_next
 #endif
@@ -140,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);
@@ -220,6 +229,7 @@ SV *line;
     SAVEPPTR(bufend);
     SAVEPPTR(oldbufptr);
     SAVEPPTR(oldoldbufptr);
+    SAVEPPTR(linestart);
     SAVESPTR(linestr);
     SAVEPPTR(lex_brackstack);
     SAVEPPTR(lex_casestack);
@@ -256,7 +266,7 @@ 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);
     SvREFCNT_dec(rs);
     rs = newSVpv("\n", 1);
@@ -272,12 +282,12 @@ static void
 restore_rsfp(f)
 void *f;
 {
-    FILE *fp = (FILE*)f;
+    PerlIO *fp = (PerlIO*)f;
 
-    if (rsfp == stdin)
-	clearerr(rsfp);
+    if (rsfp == PerlIO_stdin())
+	PerlIO_clearerr(rsfp);
     else if (rsfp && (rsfp != fp))
-	fclose(rsfp);
+	PerlIO_close(rsfp);
     rsfp = fp;
 }
 
@@ -332,6 +342,7 @@ register char *s;
 	return s;
     }
     for (;;) {
+	STRLEN prevlen;
 	while (s < bufend && isSPACE(*s))
 	    s++;
 	if (s < bufend && *s == '#') {
@@ -342,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,";}");
@@ -350,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);
 	}
     }
@@ -515,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;
@@ -578,6 +618,7 @@ sublex_start()
     SAVEPPTR(bufptr);
     SAVEPPTR(oldbufptr);
     SAVEPPTR(oldoldbufptr);
+    SAVEPPTR(linestart);
     SAVESPTR(linestr);
     SAVEPPTR(lex_brackstack);
     SAVEPPTR(lex_casestack);
@@ -585,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);
 
@@ -637,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;
@@ -965,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,
@@ -1081,8 +1122,8 @@ 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){
-		if (ferror(rsfp))
+	    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 */
@@ -1091,7 +1132,7 @@ filter_read(idx, buf_sv, maxlen)
 	} else {
 	    /* Want a line */
             if (sv_gets(buf_sv, rsfp, SvCUR(buf_sv)) == NULL) {
-		if (ferror(rsfp))
+		if (PerlIO_error(rsfp))
 	            return -1;		/* error */
 	        else
 		    return 0 ;		/* end of file */
@@ -1117,9 +1158,10 @@ filter_read(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) {
 
@@ -1130,7 +1172,7 @@ register FILE *fp;
 	    return Nullch ;
     }
     else 
-        return (sv_gets(sv, fp, 0)) ;
+        return (sv_gets(sv, fp, append));
     
 }
 
@@ -1199,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;
@@ -1320,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:
@@ -1376,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);
@@ -1388,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 */
 	    }
@@ -1418,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);
 
@@ -1480,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)
@@ -1724,7 +1767,7 @@ yylex()
       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;
@@ -1745,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++;
@@ -1837,7 +1880,7 @@ yylex()
 	    AOPERATOR(ANDAND);
 	s--;
 	if (expect == XOPERATOR) {
-	    if (dowarn && isALPHA(*s) && bufptr == SvPVX(linestr)) {
+	    if (dowarn && isALPHA(*s) && bufptr == linestart) {
 		curcop->cop_line--;
 		warn(warn_nosemi);
 		curcop->cop_line++;
@@ -1875,7 +1918,7 @@ 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;
@@ -2060,10 +2103,11 @@ yylex()
 		    }
 		}
 		if (tmp = pad_findmy(tokenbuf)) {
-		    if (!tokenbuf[2] && *tokenbuf =='$' &&
+		    if (last_lop_op == OP_SORT &&
+			!tokenbuf[2] && *tokenbuf =='$' &&
 			tokenbuf[1] <= 'b' && tokenbuf[1] >= 'a')
 		    {
-			for (d = in_eval ? oldoldbufptr : SvPVX(linestr);
+			for (d = in_eval ? oldoldbufptr : linestart;
 			    d < bufend && *d != '\n';
 			    d++)
 			{
@@ -2169,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;
@@ -2353,7 +2397,7 @@ yylex()
 		    }
 		}
 		else if (expect == XOPERATOR) {
-		    if (bufptr == SvPVX(linestr)) {
+		    if (bufptr == linestart) {
 			curcop->cop_line--;
 			warn(warn_nosemi);
 			curcop->cop_line++;
@@ -2444,6 +2488,17 @@ 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));
@@ -2469,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)
@@ -2526,13 +2582,15 @@ yylex()
 		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)) = '<';
@@ -2943,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);
 
@@ -3058,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);
@@ -3382,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);
 
@@ -4486,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++;
 	}
@@ -4498,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);
 	}
@@ -4519,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);
@@ -4664,7 +4734,7 @@ 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;
@@ -4843,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;
@@ -4893,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);
@@ -4991,7 +5063,7 @@ char *s;
     else if (in_eval)
 	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)));