X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=0ec4e9fff65654dfac8ef438619d6dbc8cfb880b;hb=973dddac3cae262865053bf44d56f52beac46f92;hp=1b16de04ba03b04c0407773bfd2f28db7fbd6a16;hpb=4c3a8340729ab239a926a5263f711fc20a0e2468;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/toke.c b/toke.c
index 1b16de0..0ec4e9f 100644
--- a/toke.c
+++ b/toke.c
@@ -66,17 +66,22 @@ static I32 utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen);
 
 /* #define LEX_NOTPARSING		11 is done in perl.h. */
 
-#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
+#define LEX_NORMAL		10 /* normal code (ie not within "...")     */
+#define LEX_INTERPNORMAL	 9 /* code within a string, eg "$foo[$x+1]" */
+#define LEX_INTERPCASEMOD	 8 /* expecting a \U, \Q or \E etc          */
+#define LEX_INTERPPUSH		 7 /* starting a new sublex parse level     */
+#define LEX_INTERPSTART		 6 /* expecting the start of a $var         */
+
+				   /* at end of code, eg "$x" followed by:  */
+#define LEX_INTERPEND		 5 /* ... eg not one of [, { or ->          */
+#define LEX_INTERPENDMAYBE	 4 /* ... eg one of [, { or ->              */
+
+#define LEX_INTERPCONCAT	 3 /* expecting anything, eg at start of
+				        string or after \E, $foo, etc       */
+#define LEX_INTERPCONST		 2 /* NOT USED */
+#define LEX_FORMLINE		 1 /* expecting a format line               */
+#define LEX_KNOWNEXT		 0 /* next token known; just return it      */
+
 
 #ifdef DEBUGGING
 static const char* const lex_state_names[] = {
@@ -136,7 +141,7 @@ static const char* const lex_state_names[] = {
  */
 
 #ifdef DEBUGGING /* Serve -DT. */
-#   define REPORT(retval) tokereport(s,(int)retval)
+#   define REPORT(retval) tokereport((I32)retval)
 #else
 #   define REPORT(retval) (retval)
 #endif
@@ -277,7 +282,7 @@ static struct debug_tokens { const int token, type; const char *name; }
 /* dump the returned token in rv, plus any optional arg in yylval */
 
 STATIC int
-S_tokereport(pTHX_ const char* s, I32 rv)
+S_tokereport(pTHX_ I32 rv)
 {
     if (DEBUG_T_TEST) {
 	const char *name = Nullch;
@@ -315,25 +320,35 @@ S_tokereport(pTHX_ const char* s, I32 rv)
 	    Perl_sv_catpvf(aTHX_ report, "(pval=\"%s\")", yylval.pval);
 	    break;
 	case TOKENTYPE_OPVAL:
-	    if (yylval.opval)
+	    if (yylval.opval) {
 		Perl_sv_catpvf(aTHX_ report, "(opval=op_%s)",
 				    PL_op_name[yylval.opval->op_type]);
+		if (yylval.opval->op_type == OP_CONST) {
+		    Perl_sv_catpvf(aTHX_ report, " %s",
+			SvPEEK(cSVOPx_sv(yylval.opval)));
+		}
+
+	    }
 	    else
 		Perl_sv_catpv(aTHX_ report, "(opval=null)");
 	    break;
 	}
-        Perl_sv_catpvf(aTHX_ report, " at line %"IVdf" [", (IV)CopLINE(PL_curcop));
-        if (s - PL_bufptr > 0)
-            sv_catpvn(report, PL_bufptr, s - PL_bufptr);
-        else {
-            if (PL_oldbufptr && *PL_oldbufptr)
-                sv_catpv(report, PL_tokenbuf);
-        }
-        PerlIO_printf(Perl_debug_log, "### %s]\n", SvPV_nolen_const(report));
+        PerlIO_printf(Perl_debug_log, "### %s\n\n", SvPV_nolen_const(report));
     };
     return (int)rv;
 }
 
+
+/* print the buffer with suitable escapes */
+
+STATIC void
+S_printbuf(pTHX_ const char* fmt, const char* s)
+{
+    SV* const tmp = newSVpvn("", 0);
+    PerlIO_printf(Perl_debug_log, fmt, pv_display(tmp, s, strlen(s), 0, 60));
+    SvREFCNT_dec(tmp);
+}
+
 #endif
 
 /*
@@ -393,12 +408,12 @@ S_no_op(pTHX_ const char *what, char *s)
 	    if (t < PL_bufptr && isSPACE(*t))
 		Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 			"\t(Do you need to predeclare %.*s?)\n",
-		    t - PL_oldoldbufptr, PL_oldoldbufptr);
+		    (int)(t - PL_oldoldbufptr), PL_oldoldbufptr);
 	}
 	else {
 	    assert(s >= oldbp);
 	    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
-		    "\t(Missing operator before %.*s?)\n", s - oldbp, oldbp);
+		    "\t(Missing operator before %.*s?)\n", (int)(s - oldbp), oldbp);
 	}
     }
     PL_bufptr = oldbp;
@@ -431,7 +446,7 @@ S_missingterm(pTHX_ char *s)
 #endif
 	) {
 	*tmpbuf = '^';
-	tmpbuf[1] = toCTRL(PL_multi_close);
+	tmpbuf[1] = (char)toCTRL(PL_multi_close);
 	tmpbuf[2] = '\0';
 	s = tmpbuf;
     }
@@ -664,6 +679,43 @@ S_incline(pTHX_ char *s)
     ch = *t;
     *t = '\0';
     if (t - s > 0) {
+#ifndef USE_ITHREADS
+	const char * const cf = CopFILE(PL_curcop);
+	if (cf && strlen(cf) > 7 && strnEQ(cf, "(eval ", 6)) {
+	    /* must copy *{"::_<(eval N)[oldfilename:L]"}
+	     * to *{"::_<newfilename"} */
+	    char smallbuf[256], smallbuf2[256];
+	    char *tmpbuf, *tmpbuf2;
+	    GV **gvp, *gv2;
+	    STRLEN tmplen = strlen(cf);
+	    STRLEN tmplen2 = strlen(s);
+	    if (tmplen + 3 < sizeof smallbuf)
+		tmpbuf = smallbuf;
+	    else
+		Newx(tmpbuf, tmplen + 3, char);
+	    if (tmplen2 + 3 < sizeof smallbuf2)
+		tmpbuf2 = smallbuf2;
+	    else
+		Newx(tmpbuf2, tmplen2 + 3, char);
+	    tmpbuf[0] = tmpbuf2[0] = '_';
+	    tmpbuf[1] = tmpbuf2[1] = '<';
+	    memcpy(tmpbuf + 2, cf, ++tmplen);
+	    memcpy(tmpbuf2 + 2, s, ++tmplen2);
+	    ++tmplen; ++tmplen2;
+	    gvp = (GV**)hv_fetch(PL_defstash, tmpbuf, tmplen, FALSE);
+	    if (gvp) {
+		gv2 = *(GV**)hv_fetch(PL_defstash, tmpbuf2, tmplen2, TRUE);
+		if (!isGV(gv2))
+		    gv_init(gv2, PL_defstash, tmpbuf2, tmplen2, FALSE);
+		/* adjust ${"::_<newfilename"} to store the new file name */
+		GvSV(gv2) = newSVpvn(tmpbuf2 + 2, tmplen2 - 2);
+		GvHV(gv2) = (HV*)SvREFCNT_inc(GvHV(*gvp));
+		GvAV(gv2) = (AV*)SvREFCNT_inc(GvAV(*gvp));
+	    }
+	    if (tmpbuf != smallbuf) Safefree(tmpbuf);
+	    if (tmpbuf2 != smallbuf2) Safefree(tmpbuf2);
+	}
+#endif
 	CopFILE_free(PL_curcop);
 	CopFILE_set(PL_curcop, s);
     }
@@ -1118,7 +1170,7 @@ S_tokeq(pTHX_ SV *sv)
 STATIC I32
 S_sublex_start(pTHX)
 {
-    const register I32 op_type = yylval.ival;
+    register const I32 op_type = yylval.ival;
 
     if (op_type == OP_NULL) {
 	yylval.opval = PL_lex_op;
@@ -2293,6 +2345,30 @@ S_find_in_my_stash(pTHX_ const char *pkgname, I32 len)
     return gv_stashpv(pkgname, FALSE);
 }
 
+STATIC char *
+S_tokenize_use(pTHX_ int is_use, char *s) {
+    if (PL_expect != XSTATE)
+	yyerror(Perl_form(aTHX_ "\"%s\" not allowed in expression",
+		    is_use ? "use" : "no"));
+    s = skipspace(s);
+    if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
+	s = force_version(s, TRUE);
+	if (*s == ';' || (s = skipspace(s), *s == ';')) {
+	    PL_nextval[PL_nexttoke].opval = Nullop;
+	    force_next(WORD);
+	}
+	else if (*s == 'v') {
+	    s = force_word(s,WORD,FALSE,TRUE,FALSE);
+	    s = force_version(s, FALSE);
+	}
+    }
+    else {
+	s = force_word(s,WORD,FALSE,TRUE,FALSE);
+	s = force_version(s, FALSE);
+    }
+    yylval.ival = is_use;
+    return s;
+}
 #ifdef DEBUGGING
     static const char* const exp_name[] =
 	{ "OPERATOR", "TERM", "REF", "STATE", "BLOCK", "ATTRBLOCK",
@@ -2342,8 +2418,13 @@ Perl_yylex(pTHX)
     I32 orig_keyword = 0;
 
     DEBUG_T( {
-	PerlIO_printf(Perl_debug_log, "### LEX_%s\n",
-					lex_state_names[PL_lex_state]);
+	SV* tmp = newSVpvn("", 0);
+	PerlIO_printf(Perl_debug_log, "### %"IVdf":LEX_%s/X%s %s\n",
+	    (IV)CopLINE(PL_curcop),
+	    lex_state_names[PL_lex_state],
+	    exp_name[PL_expect],
+	    pv_display(tmp, s, strlen(s), 0, 60));
+	SvREFCNT_dec(tmp);
     } );
     /* check if there's an identifier for us to look at */
     if (PL_pending_ident)
@@ -2367,10 +2448,6 @@ Perl_yylex(pTHX)
 	    PL_expect = PL_lex_expect;
 	    PL_lex_defer = LEX_NORMAL;
 	}
-	DEBUG_T({ PerlIO_printf(Perl_debug_log,
-              "### Next token after '%s' was known, type %"IVdf"\n", PL_bufptr,
-              (IV)PL_nexttype[PL_nexttoke]); });
-
 	return REPORT(PL_nexttype[PL_nexttoke]);
 
     /* interpolated case modifiers like \L \U, including \Q and \E.
@@ -2402,7 +2479,7 @@ Perl_yylex(pTHX)
 	}
 	else {
 	    DEBUG_T({ PerlIO_printf(Perl_debug_log,
-              "### Saw case modifier at '%s'\n", PL_bufptr); });
+              "### Saw case modifier\n"); });
 	    s = PL_bufptr + 1;
 	    if (s[1] == '\\' && s[2] == 'E') {
 	        PL_bufptr = s + 3;
@@ -2459,7 +2536,7 @@ Perl_yylex(pTHX)
 	if (PL_bufptr == PL_bufend)
 	    return REPORT(sublex_done());
 	DEBUG_T({ PerlIO_printf(Perl_debug_log,
-              "### Interpolated variable at '%s'\n", PL_bufptr); });
+              "### Interpolated variable\n"); });
 	PL_expect = XTERM;
 	PL_lex_dojoin = (*PL_bufptr == '@');
 	PL_lex_state = LEX_INTERPNORMAL;
@@ -2559,10 +2636,6 @@ Perl_yylex(pTHX)
     s = PL_bufptr;
     PL_oldoldbufptr = PL_oldbufptr;
     PL_oldbufptr = s;
-    DEBUG_T( {
-	PerlIO_printf(Perl_debug_log, "### Tokener expecting %s at [%s]\n",
-		      exp_name[PL_expect], s);
-    } );
 
   retry:
     switch (*s) {
@@ -2779,7 +2852,7 @@ Perl_yylex(pTHX)
 		     * 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)); /* $^X */
+		    SV * const x = GvSV(gv_fetchpv("\030", TRUE, SVt_PV)); /* $^X */
 		    assert(SvPOK(x) || SvGMAGICAL(x));
 		    if (sv_eq(x, CopFILESV(PL_curcop))) {
 			sv_setpvn(x, ipath, ipathend - ipath);
@@ -2987,8 +3060,8 @@ Perl_yylex(pTHX)
 
 	    if (strnEQ(s,"=>",2)) {
 		s = force_word(PL_bufptr,WORD,FALSE,FALSE,FALSE);
-                DEBUG_T( { PerlIO_printf(Perl_debug_log,
-                            "### Saw unary minus before =>, forcing word '%s'\n", s);
+                DEBUG_T( { S_printbuf(aTHX_
+			"### Saw unary minus before =>, forcing word %s\n", s);
                 } );
 		OPERATOR('-');		/* unary minus */
 	    }
@@ -3033,7 +3106,7 @@ Perl_yylex(pTHX)
 	    if (ftst) {
 		PL_last_lop_op = (OPCODE)ftst;
 		DEBUG_T( { PerlIO_printf(Perl_debug_log,
-                        "### Saw file test %c\n", (int)ftst);
+                        "### Saw file test %c\n", (int)tmp);
 		} );
 		FTST(ftst);
 	    }
@@ -3866,18 +3939,14 @@ Perl_yylex(pTHX)
     case '0': case '1': case '2': case '3': case '4':
     case '5': case '6': case '7': case '8': case '9':
 	s = scan_num(s, &yylval);
-        DEBUG_T( { PerlIO_printf(Perl_debug_log,
-                    "### Saw number in '%s'\n", s);
-        } );
+	DEBUG_T( { S_printbuf(aTHX_ "### Saw number in %s\n", s); } );
 	if (PL_expect == XOPERATOR)
 	    no_op("Number",s);
 	TERM(THING);
 
     case '\'':
 	s = scan_str(s,FALSE,FALSE);
-        DEBUG_T( { PerlIO_printf(Perl_debug_log,
-                    "### Saw string before '%s'\n", s);
-        } );
+	DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
 	if (PL_expect == XOPERATOR) {
 	    if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
 		PL_expect = XTERM;
@@ -3894,9 +3963,7 @@ Perl_yylex(pTHX)
 
     case '"':
 	s = scan_str(s,FALSE,FALSE);
-        DEBUG_T( { PerlIO_printf(Perl_debug_log,
-                    "### Saw string before '%s'\n", s);
-        } );
+	DEBUG_T( { S_printbuf(aTHX_ "### Saw string before %s\n", s); } );
 	if (PL_expect == XOPERATOR) {
 	    if (PL_lex_formbrack && PL_lex_brackets == PL_lex_formbrack) {
 		PL_expect = XTERM;
@@ -3921,9 +3988,7 @@ Perl_yylex(pTHX)
 
     case '`':
 	s = scan_str(s,FALSE,FALSE);
-        DEBUG_T( { PerlIO_printf(Perl_debug_log,
-                    "### Saw backtick string before '%s'\n", s);
-        } );
+	DEBUG_T( { S_printbuf(aTHX_ "### Saw backtick string before %s\n", s); } );
 	if (PL_expect == XOPERATOR)
 	    no_op("Backticks",s);
 	if (!s)
@@ -4207,11 +4272,16 @@ Perl_yylex(pTHX)
 
 		    /* If not a declared subroutine, it's an indirect object. */
 		    /* (But it's an indir obj regardless for sort.) */
+		    /* Also, if "_" follows a filetest operator, it's a bareword */
 
-		    if ( !immediate_paren && (PL_last_lop_op == OP_SORT ||
+		    if (
+			( !immediate_paren && (PL_last_lop_op == OP_SORT ||
                          ((!gv || !GvCVu(gv)) &&
                         (PL_last_lop_op != OP_MAPSTART &&
 			 PL_last_lop_op != OP_GREPSTART))))
+		       || (PL_tokenbuf[0] == '_' && PL_tokenbuf[1] == '\0'
+			    && ((PL_opargs[PL_last_lop_op] & OA_CLASS_MASK) == OA_FILESTATOP))
+		       )
 		    {
 			PL_expect = (PL_last_lop == PL_oldoldbufptr) ? XTERM : XOPERATOR;
 			goto bareword;
@@ -4459,6 +4529,9 @@ Perl_yylex(pTHX)
 		    Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
 		if (tmp < 0)
 		    tmp = -tmp;
+		else if (tmp == KEY_require || tmp == KEY_do)
+		    /* that's a way to remember we saw "CORE::" */
+		    orig_keyword = tmp;
 		goto reserved_word;
 	    }
 	    goto just_a_word;
@@ -4542,6 +4615,12 @@ Perl_yylex(pTHX)
 		PRETERMBLOCK(DO);
 	    if (*s != '\'')
 		s = force_word(s,WORD,TRUE,TRUE,FALSE);
+	    if (orig_keyword == KEY_do) {
+		orig_keyword = 0;
+		yylval.ival = 1;
+	    }
+	    else
+		yylval.ival = 0;
 	    OPERATOR(DO);
 
 	case KEY_die:
@@ -4871,11 +4950,7 @@ Perl_yylex(pTHX)
 	    Eop(OP_SNE);
 
 	case KEY_no:
-	    if (PL_expect != XSTATE)
-		yyerror("\"no\" not allowed in expression");
-	    s = force_word(s,WORD,FALSE,TRUE,FALSE);
-	    s = force_version(s, FALSE);
-	    yylval.ival = 0;
+	    s = tokenize_use(0, s);
 	    OPERATOR(USE);
 
 	case KEY_not:
@@ -4894,9 +4969,10 @@ Perl_yylex(pTHX)
 		    /* [perl #16184] */
 		    && !(t[0] == '=' && t[1] == '>')
 		) {
+		    int len = (int)(d-s);
 		    Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
 			   "Precedence problem: open %.*s should be open(%.*s)",
-			    d - s, s, d - s, s);
+			    len, s, len, s);
 		}
 	    }
 	    LOP(OP_OPEN,XTERM);
@@ -5044,7 +5120,18 @@ Perl_yylex(pTHX)
 		else if (*s == '<')
 		    yyerror("<> should be quotes");
 	    }
-	    UNI(OP_REQUIRE);
+	    if (orig_keyword == KEY_require) {
+		orig_keyword = 0;
+		yylval.ival = 1;
+	    }
+	    else 
+		yylval.ival = 0;
+	    PL_expect = XTERM;
+	    PL_bufptr = s;
+	    PL_last_uni = PL_oldbufptr;
+	    PL_last_lop_op = OP_REQUIRE;
+	    s = skipspace(s);
+	    return REPORT( (int)REQUIRE );
 
 	case KEY_reset:
 	    UNI(OP_RESET);
@@ -5407,25 +5494,7 @@ Perl_yylex(pTHX)
 	    LOP(OP_UNSHIFT,XTERM);
 
 	case KEY_use:
-	    if (PL_expect != XSTATE)
-		yyerror("\"use\" not allowed in expression");
-	    s = skipspace(s);
-	    if (isDIGIT(*s) || (*s == 'v' && isDIGIT(s[1]))) {
-		s = force_version(s, TRUE);
-		if (*s == ';' || (s = skipspace(s), *s == ';')) {
-		    PL_nextval[PL_nexttoke].opval = Nullop;
-		    force_next(WORD);
-		}
-		else if (*s == 'v') {
-		    s = force_word(s,WORD,FALSE,TRUE,FALSE);
-		    s = force_version(s, FALSE);
-		}
-	    }
-	    else {
-		s = force_word(s,WORD,FALSE,TRUE,FALSE);
-		s = force_version(s, FALSE);
-	    }
-	    yylval.ival = 1;
+	    s = tokenize_use(1, s);
 	    OPERATOR(USE);
 
 	case KEY_values:
@@ -5494,7 +5563,7 @@ S_pending_ident(pTHX)
     PL_pending_ident = 0;
 
     DEBUG_T({ PerlIO_printf(Perl_debug_log,
-          "### Tokener saw identifier '%s'\n", PL_tokenbuf); });
+          "### Pending identifier '%s'\n", PL_tokenbuf); });
 
     /* if we're in a my(), we can't allow dynamics here.
        $foo'bar has already been turned into $foo::bar, so