X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=f6977417143d8ce366f24f4af15df341b2ab5f37;hb=245ccdfc96e80a37f854d10e16cf1eb342c49934;hp=9db82c6bfcded7db7f21263616a40c3516124d34;hpb=d931506569a96775e3023a9788567281463988c6;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/toke.c b/toke.c
index 9db82c6..f697741 100644
--- a/toke.c
+++ b/toke.c
@@ -112,15 +112,13 @@ static char ident_too_long[] = "Identifier too long";
 #ifdef USE_PURE_BISON
 YYSTYPE* yylval_pointer = NULL;
 int* yychar_pointer = NULL;
-#ifdef EMBED
-#undef yylval
-#undef yychar
-#endif
-#define yylval (*yylval_pointer)
-#define yychar (*yychar_pointer)
-#define YYLEXPARAM yylval_pointer,yychar_pointer
+#  undef yylval
+#  undef yychar
+#  define yylval (*yylval_pointer)
+#  define yychar (*yychar_pointer)
+#  define PERL_YYLEX_PARAM yylval_pointer,yychar_pointer
 #else
-#define YYLEXPARAM
+#  define PERL_YYLEX_PARAM
 #endif
 
 #include "keywords.h"
@@ -201,6 +199,8 @@ no_op(char *what, char *s)
 		t - PL_oldoldbufptr, PL_oldoldbufptr);
 
     }
+    else if (s <= oldbp)
+	warn("\t(Missing operator before end of line?)\n");
     else
 	warn("\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
     PL_bufptr = oldbp;
@@ -447,13 +447,20 @@ skipspace(register char *s)
     }
     for (;;) {
 	STRLEN prevlen;
-	while (s < PL_bufend && isSPACE(*s))
-	    s++;
+	while (s < PL_bufend && isSPACE(*s)) {
+	    if (*s++ == '\n' && PL_in_eval && !PL_rsfp)
+		incline(s);
+	}
 	if (s < PL_bufend && *s == '#') {
 	    while (s < PL_bufend && *s != '\n')
 		s++;
-	    if (s < PL_bufend)
+	    if (s < PL_bufend) {
 		s++;
+		if (PL_in_eval && !PL_rsfp) {
+		    incline(s);
+		    continue;
+		}
+	    }
 	}
 	if (s < PL_bufend || !PL_rsfp || PL_lex_state != LEX_NORMAL)
 	    return s;
@@ -798,7 +805,7 @@ sublex_done(void)
 
     if (PL_lex_casemods) {		/* oops, we've got some unbalanced parens */
 	PL_lex_state = LEX_INTERPCASEMOD;
-	return yylex(YYLEXPARAM);
+	return yylex(PERL_YYLEX_PARAM);
     }
 
     /* Is there a right-hand side to take care of? */
@@ -817,10 +824,15 @@ sublex_done(void)
 	if (SvCOMPILED(PL_lex_repl)) {
 	    PL_lex_state = LEX_INTERPNORMAL;
 	    PL_lex_starts++;
+	    /*	we don't clear PL_lex_repl here, so that we can check later
+		whether this is an evalled subst; that means we rely on the
+		logic to ensure sublex_done() is called again only via the
+		branch (in yylex()) that clears PL_lex_repl, else we'll loop */
 	}
-	else
+	else {
 	    PL_lex_state = LEX_INTERPCONCAT;
-	PL_lex_repl = Nullsv;
+	    PL_lex_repl = Nullsv;
+	}
 	return ',';
     }
     else {
@@ -1051,7 +1063,7 @@ scan_const(char *start)
 	    s++;
 
 	    /* some backslashes we leave behind */
-	    if (*s && strchr(leaveit, *s)) {
+	    if (*leaveit && *s && strchr(leaveit, *s)) {
 		*d++ = '\\';
 		*d++ = *s++;
 		continue;
@@ -1084,10 +1096,17 @@ scan_const(char *start)
 		    continue;
 		}
 		/* FALL THROUGH */
-	    /* default action is to copy the quoted character */
 	    default:
-		*d++ = *s++;
-		continue;
+	        {
+		    dTHR;
+		    if (ckWARN(WARN_UNSAFE) && isALPHA(*s))
+			warner(WARN_UNSAFE, 
+			       "Unrecognized escape \\%c passed through",
+			       *s);
+		    /* default action is to copy the quoted character */
+		    *d++ = *s++;
+		    continue;
+		}
 
 	    /* \132 indicates an octal constant */
 	    case '0': case '1': case '2': case '3':
@@ -1431,13 +1450,12 @@ incl_perldb(void)
  * 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(filter_t funcp, SV *datasv)
 {
     if (!funcp){ /* temporary handy debugging hack to be deleted */
-	filter_debug = atoi((char*)datasv);
+	PL_filter_debug = atoi((char*)datasv);
 	return NULL;
     }
     if (!PL_rsfp_filters)
@@ -1447,8 +1465,10 @@ filter_add(filter_t funcp, SV *datasv)
     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 %p (%s)", funcp, SvPV(datasv,PL_na));
+    if (PL_filter_debug) {
+	STRLEN n_a;
+	warn("filter_add func %p (%s)", funcp, SvPV(datasv, n_a));
+    }
     av_unshift(PL_rsfp_filters, 1);
     av_store(PL_rsfp_filters, 0, datasv) ;
     return(datasv);
@@ -1459,7 +1479,7 @@ filter_add(filter_t funcp, SV *datasv)
 void
 filter_del(filter_t funcp)
 {
-    if (filter_debug)
+    if (PL_filter_debug)
 	warn("filter_del func %p", funcp);
     if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0)
 	return;
@@ -1489,7 +1509,7 @@ filter_read(int idx, SV *buf_sv, int maxlen)
     if (idx > AvFILLp(PL_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)
+	if (PL_filter_debug)
 	    warn("filter_read %d: from rsfp\n", idx);
 	if (maxlen) { 
  	    /* Want a block */
@@ -1518,15 +1538,17 @@ filter_read(int idx, SV *buf_sv, int maxlen)
     }
     /* Skip this filter slot if filter has been deleted	*/
     if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){
-	if (filter_debug)
+	if (PL_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)
+    if (PL_filter_debug) {
+	STRLEN n_a;
 	warn("filter_read %d: via function %p (%s)\n",
-		idx, funcp, SvPV(datasv,PL_na));
+		idx, funcp, SvPV(datasv,n_a));
+    }
     /* Call function. The function is expected to 	*/
     /* call "FILTER_READ(idx+1, buf_sv)" first.		*/
     /* Return: <0:error, =0:eof, >0:not eof 		*/
@@ -1585,12 +1607,7 @@ filter_gets(register SV *sv, register PerlIO *fp, STRLEN append)
       if we already built the token before, use it.
 */
 
-int yylex
-#ifdef USE_PURE_BISON
-(YYSTYPE* lvalp, int* lcharp)
-#else
-(void)
-#endif
+int yylex(PERL_YYLEX_PARAM_DECL)
 {
     dTHR;
     register char *s;
@@ -1619,7 +1636,7 @@ int yylex
 	*/
 	if (PL_in_my) {
 	    if (strchr(PL_tokenbuf,':'))
-		croak(no_myglob,PL_tokenbuf);
+		croak(PL_no_myglob,PL_tokenbuf);
 
 	    yylval.opval = newOP(OP_PADANY, 0);
 	    yylval.opval->op_targ = pad_allocmy(PL_tokenbuf);
@@ -1742,7 +1759,7 @@ int yylex
 	    if (PL_bufptr != PL_bufend)
 		PL_bufptr += 2;
 	    PL_lex_state = LEX_INTERPCONCAT;
-	    return yylex(YYLEXPARAM);
+	    return yylex(PERL_YYLEX_PARAM);
 	}
 	else {
 	    s = PL_bufptr + 1;
@@ -1786,7 +1803,7 @@ int yylex
 		Aop(OP_CONCAT);
 	    }
 	    else
-		return yylex(YYLEXPARAM);
+		return yylex(PERL_YYLEX_PARAM);
 	}
 
     case LEX_INTERPPUSH:
@@ -1819,7 +1836,7 @@ int yylex
 	    s = PL_bufptr;
 	    Aop(OP_CONCAT);
 	}
-	return yylex(YYLEXPARAM);
+	return yylex(PERL_YYLEX_PARAM);
 
     case LEX_INTERPENDMAYBE:
 	if (intuit_more(PL_bufptr)) {
@@ -1834,6 +1851,11 @@ int yylex
 	    PL_lex_state = LEX_INTERPCONCAT;
 	    return ')';
 	}
+	if (PL_lex_inwhat == OP_SUBST && PL_lex_repl && SvCOMPILED(PL_lex_repl)) {
+	    if (PL_bufptr != PL_bufend)
+		croak("Bad evalled substitution pattern");
+	    PL_lex_repl = Nullsv;
+	}
 	/* FALLTHROUGH */
     case LEX_INTERPCONCAT:
 #ifdef DEBUGGING
@@ -1868,11 +1890,11 @@ int yylex
 		Aop(OP_CONCAT);
 	    else {
 		PL_bufptr = s;
-		return yylex(YYLEXPARAM);
+		return yylex(PERL_YYLEX_PARAM);
 	    }
 	}
 
-	return yylex(YYLEXPARAM);
+	return yylex(PERL_YYLEX_PARAM);
     case LEX_FORMLINE:
 	PL_lex_state = LEX_NORMAL;
 	s = scan_formline(PL_bufptr);
@@ -2111,7 +2133,7 @@ int yylex
 		    else
 			newargv = PL_origargv;
 		    newargv[0] = ipath;
-		    execv(ipath, newargv);
+		    PerlProc_execv(ipath, newargv);
 		    croak("Can't exec %s", ipath);
 		}
 		if (d) {
@@ -2152,7 +2174,7 @@ int yylex
 	if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
 	    PL_bufptr = s;
 	    PL_lex_state = LEX_FORMLINE;
-	    return yylex(YYLEXPARAM);
+	    return yylex(PERL_YYLEX_PARAM);
 	}
 	goto retry;
     case '\r':
@@ -2176,7 +2198,7 @@ int yylex
 	    if (PL_lex_formbrack && PL_lex_brackets <= PL_lex_formbrack) {
 		PL_bufptr = s;
 		PL_lex_state = LEX_FORMLINE;
-		return yylex(YYLEXPARAM);
+		return yylex(PERL_YYLEX_PARAM);
 	    }
 	}
 	else {
@@ -2513,7 +2535,7 @@ int yylex
 		if (PL_lex_fakebrack) {
 		    PL_lex_state = LEX_INTERPEND;
 		    PL_bufptr = s;
-		    return yylex(YYLEXPARAM);	/* ignore fake brackets */
+		    return yylex(PERL_YYLEX_PARAM);	/* ignore fake brackets */
 		}
 		if (*s == '-' && s[1] == '>')
 		    PL_lex_state = LEX_INTERPENDMAYBE;
@@ -2524,7 +2546,7 @@ int yylex
 	if (PL_lex_brackets < PL_lex_fakebrack) {
 	    PL_bufptr = s;
 	    PL_lex_fakebrack = 0;
-	    return yylex(YYLEXPARAM);		/* ignore fake brackets */
+	    return yylex(PERL_YYLEX_PARAM);		/* ignore fake brackets */
 	}
 	force_next('}');
 	TOKEN(';');
@@ -2537,7 +2559,7 @@ int yylex
 	if (PL_expect == XOPERATOR) {
 	    if (ckWARN(WARN_SEMICOLON) && isIDFIRST_lazy(s) && PL_bufptr == PL_linestart) {
 		PL_curcop->cop_line--;
-		warner(WARN_SEMICOLON, warn_nosemi);
+		warner(WARN_SEMICOLON, PL_warn_nosemi);
 		PL_curcop->cop_line++;
 	    }
 	    BAop(OP_BIT_AND);
@@ -2728,7 +2750,8 @@ int yylex
 		    for (t++; isSPACE(*t); t++) ;
 		    if (isIDFIRST_lazy(t)) {
 			t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
-			if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
+		        for (; isSPACE(*t); t++) ;
+			if (*t == ';' && perl_get_cv(tmpbuf, FALSE))
 			    warner(WARN_SYNTAX,
 				"You need to quote \"%s\"", tmpbuf);
 		    }
@@ -2775,9 +2798,9 @@ int yylex
 		PL_expect = XTERM;		/* e.g. print $fh 3 */
 	    else if (*s == '.' && isDIGIT(s[1]))
 		PL_expect = XTERM;		/* e.g. print $fh .3 */
-	    else if (strchr("/?-+", *s) && !isSPACE(s[1]))
+	    else if (strchr("/?-+", *s) && !isSPACE(s[1]) && s[1] != '=')
 		PL_expect = XTERM;		/* e.g. print $fh -1 */
-	    else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]))
+	    else if (*s == '<' && s[1] == '<' && !isSPACE(s[2]) && s[2] != '=')
 		PL_expect = XTERM;		/* print $fh <<"EOF" */
 	}
 	PL_pending_ident = '$';
@@ -2964,6 +2987,7 @@ int yylex
     case 'z': case 'Z':
 
       keylookup: {
+	STRLEN n_a;
 	gv = Nullgv;
 	gvp = 0;
 
@@ -3069,7 +3093,7 @@ int yylex
 		if (PL_expect == XOPERATOR) {
 		    if (PL_bufptr == PL_linestart) {
 			PL_curcop->cop_line--;
-			warner(WARN_SEMICOLON, warn_nosemi);
+			warner(WARN_SEMICOLON, PL_warn_nosemi);
 			PL_curcop->cop_line++;
 		    }
 		    else
@@ -3125,7 +3149,7 @@ int yylex
 		    (PL_oldoldbufptr == PL_last_lop || PL_oldoldbufptr == PL_last_uni) &&
 		    /* NO SKIPSPACE BEFORE HERE! */
 		    (PL_expect == XREF 
-		     || ((opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
+		     || ((PL_opargs[PL_last_lop_op] >> OASHIFT)& 7) == OA_FILEREF
 		     || (PL_last_lop_op == OP_ENTERSUB 
 			 && PL_last_proto 
 			 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*')) )
@@ -3158,8 +3182,11 @@ int yylex
 		if (*s == '(') {
 		    CLINE;
 		    if (gv && GvCVu(gv)) {
+			CV *cv;
+			if ((cv = GvCV(gv)) && SvPOK(cv))
+			    PL_last_proto = SvPV((SV*)cv, n_a);
 			for (d = s + 1; *d == ' ' || *d == '\t'; d++) ;
-			if (*d == ')' && (sv = cv_const_sv(GvCV(gv)))) {
+			if (*d == ')' && (sv = cv_const_sv(cv))) {
 			    s = d + 1;
 			    goto its_constant;
 			}
@@ -3168,6 +3195,7 @@ int yylex
 		    PL_expect = XOPERATOR;
 		    force_next(WORD);
 		    yylval.ival = 0;
+		    PL_last_lop_op = OP_ENTERSUB;
 		    TOKEN('&');
 		}
 
@@ -3206,6 +3234,7 @@ int yylex
 		    /* Resolve to GV now. */
 		    op_free(yylval.opval);
 		    yylval.opval = newCVREF(0, newGVOP(OP_GV, 0, gv));
+		    PL_last_lop_op = OP_ENTERSUB;
 		    /* Is there a prototype? */
 		    if (SvPOK(cv)) {
 			STRLEN len;
@@ -3232,7 +3261,10 @@ int yylex
 		    PL_last_lop_op != OP_TRUNCATE &&  /* S/F prototype in opcode.pl */
 		    PL_last_lop_op != OP_ACCEPT &&
 		    PL_last_lop_op != OP_PIPE_OP &&
-		    PL_last_lop_op != OP_SOCKPAIR)
+		    PL_last_lop_op != OP_SOCKPAIR &&
+		    !(PL_last_lop_op == OP_ENTERSUB 
+			 && PL_last_proto 
+			 && PL_last_proto[PL_last_proto[0] == ';' ? 1 : 0] == '*'))
 		{
 		    warn(
 		     "Bareword \"%s\" not allowed while \"strict subs\" in use",
@@ -3247,7 +3279,7 @@ int yylex
 		    if (lastchar != '-') {
 			for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
 			if (!*d)
-			    warner(WARN_RESERVED, warn_reserved, PL_tokenbuf);
+			    warner(WARN_RESERVED, PL_warn_reserved, PL_tokenbuf);
 		    }
 		}
 
@@ -4110,7 +4142,7 @@ int yylex
 		PL_lex_stuff = Nullsv;
 	    }
 
-	    if (*SvPV(PL_subname,PL_na) == '?') {
+	    if (*SvPV(PL_subname,n_a) == '?') {
 		sv_setpv(PL_subname,"__ANON__");
 		TOKEN(ANONSUB);
 	    }
@@ -4950,7 +4982,6 @@ new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
     bool oldcatch = CATCH_GET;
     SV **cvp;
     SV *cv, *typesv;
-    char buf[128];
 	    
     if (!table) {
 	yyerror("%^H is not defined");
@@ -4958,6 +4989,7 @@ new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
     }
     cvp = hv_fetch(table, key, strlen(key), FALSE);
     if (!cvp || !SvOK(*cvp)) {
+	char buf[128];
 	sprintf(buf,"$^H{%s} is not defined", key);
 	yyerror(buf);
 	return sv;
@@ -5003,6 +5035,7 @@ new_constant(char *s, STRLEN len, char *key, SV *sv, SV *pv, char *type)
     POPSTACK;
 
     if (!SvOK(res)) {
+	char buf[128];
 	sprintf(buf,"Call to &{$^H{%s}} did not return a defined value", key);
 	yyerror(buf);
     }
@@ -5641,16 +5674,16 @@ scan_inputsymbol(char *start)
 	    if ((tmp = pad_findmy(d)) != NOT_IN_PAD) {
 		OP *o = newOP(OP_PADSV, 0);
 		o->op_targ = tmp;
-		PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, newUNOP(OP_RV2GV, 0, o));
+		PL_lex_op = (OP*)newUNOP(OP_READLINE, 0, o);
 	    }
 	    else {
 		GV *gv = gv_fetchpv(d+1,TRUE, SVt_PV);
 		PL_lex_op = (OP*)newUNOP(OP_READLINE, 0,
-					newUNOP(OP_RV2GV, 0,
 					    newUNOP(OP_RV2SV, 0,
-						newGVOP(OP_GV, 0, gv))));
+						newGVOP(OP_GV, 0, gv)));
 	    }
-	    /* we created the ops in lex_op, so make yylval.ival a null op */
+	    PL_lex_op->op_flags |= OPf_SPECIAL;
+	    /* we created the ops in PL_lex_op, so make yylval.ival a null op */
 	    yylval.ival = OP_NULL;
 	}
 
@@ -5880,7 +5913,7 @@ scan_str(char *start)
 
   Read a number in any of the formats that Perl accepts:
 
-  0(x[0-7A-F]+)|([0-7]+)
+  0(x[0-7A-F]+)|([0-7]+)|(b[01])
   [\d_]+(\.[\d_]*)?[Ee](\d+)
 
   Underbars (_) are allowed in decimal numbers.  If -w is on,
@@ -5914,18 +5947,19 @@ scan_num(char *start)
       croak("panic: scan_num");
       
     /* if it starts with a 0, it could be an octal number, a decimal in
-       0.13 disguise, or a hexadecimal number.
+       0.13 disguise, or a hexadecimal number, or a binary number.
     */
     case '0':
 	{
 	  /* variables:
 	     u		holds the "number so far"
-	     shift	the power of 2 of the base (hex == 4, octal == 3)
+	     shift	the power of 2 of the base
+			(hex == 4, octal == 3, binary == 1)
 	     overflowed	was the number more than we can hold?
 
 	     Shift is used when we add a digit.  It also serves as an "are
-	     we in octal or hex?" indicator to disallow hex characters when
-	     in octal mode.
+	     we in octal/hex/binary?" indicator to disallow hex characters
+	     when in octal mode.
 	   */
 	    UV u;
 	    I32 shift;
@@ -5935,6 +5969,9 @@ scan_num(char *start)
 	    if (s[1] == 'x') {
 		shift = 4;
 		s += 2;
+	    } else if (s[1] == 'b') {
+		shift = 1;
+		s += 2;
 	    }
 	    /* check for a decimal in disguise */
 	    else if (s[1] == '.')
@@ -5944,7 +5981,7 @@ scan_num(char *start)
 		shift = 3;
 	    u = 0;
 
-	    /* read the rest of the octal number */
+	    /* read the rest of the number */
 	    for (;;) {
 		UV n, b;	/* n is used in the overflow test, b is the digit we're adding on */
 
@@ -5961,13 +5998,21 @@ scan_num(char *start)
 
 		/* 8 and 9 are not octal */
 		case '8': case '9':
-		    if (shift != 4)
+		    if (shift == 3)
 			yyerror("Illegal octal digit");
+		    else
+			if (shift == 1)
+			    yyerror("Illegal binary digit");
 		    /* FALL THROUGH */
 
 	        /* octal digits */
-		case '0': case '1': case '2': case '3': case '4':
+		case '2': case '3': case '4':
 		case '5': case '6': case '7':
+		    if (shift == 1)
+			yyerror("Illegal binary digit");
+		    /* FALL THROUGH */
+
+		case '0': case '1':
 		    b = *s++ & 15;		/* ASCII digit -> value of digit */
 		    goto digit;
 
@@ -5988,7 +6033,8 @@ scan_num(char *start)
 		    if (!overflowed && (n >> shift) != u
 			&& !(PL_hints & HINT_NEW_BINARY)) {
 			warn("Integer overflow in %s number",
-			     (shift == 4) ? "hex" : "octal");
+			     (shift == 4) ? "hex"
+			     : ((shift == 3) ? "octal" : "binary"));
 			overflowed = TRUE;
 		    }
 		    u = n | b;		/* add the digit to the end */
@@ -6139,7 +6185,7 @@ scan_formline(register char *s)
 #else
 	    for (t = s+1;*t == ' ' || *t == '\t' || *t == '\r'; t++) ;
 #endif
-	    if (*t == '\n')
+	    if (*t == '\n' || t == PL_bufend)
 		break;
 	}
 	if (PL_in_eval && !PL_rsfp) {