X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=93623f6740571ec43776abb963c6beee5f75435f;hb=b1ddf169801254979af17f682f37e96143b35982;hp=780855e0490f41aa435e4327fad3a3f9e5e6d5b5;hpb=890ce7af62ab97fd07b5b49562f13e94286469fb;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/toke.c b/toke.c
index 780855e..93623f6 100644
--- a/toke.c
+++ b/toke.c
@@ -664,6 +664,43 @@ S_incline(pTHX_ char *s)
     ch = *t;
     *t = '\0';
     if (t - s > 0) {
+#ifndef USE_ITHREADS
+	const char *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);
     }
@@ -1368,6 +1405,9 @@ S_scan_const(pTHX_ char *start)
     I32  has_utf8 = FALSE;			/* Output constant is UTF8 */
     I32  this_utf8 = UTF;			/* The source string is assumed to be UTF8 */
     UV uv;
+#ifdef EBCDIC
+    UV literal_endpoint = 0;
+#endif
 
     const char *leaveit =	/* set of acceptably-backslashed characters */
 	PL_lex_inpat
@@ -1417,8 +1457,9 @@ S_scan_const(pTHX_ char *start)
                 }
 
 #ifdef EBCDIC
-		if ((isLOWER(min) && isLOWER(max)) ||
-		    (isUPPER(min) && isUPPER(max))) {
+		if (literal_endpoint == 2 &&
+		    ((isLOWER(min) && isLOWER(max)) ||
+		     (isUPPER(min) && isUPPER(max)))) {
 		    if (isLOWER(min)) {
 			for (i = min; i <= max; i++)
 			    if (isLOWER(i))
@@ -1437,6 +1478,9 @@ S_scan_const(pTHX_ char *start)
 		/* mark the range as done, and continue */
 		dorange = FALSE;
 		didrange = TRUE;
+#ifdef EBCDIC
+		literal_endpoint = 0;
+#endif
 		continue;
 	    }
 
@@ -1455,6 +1499,9 @@ S_scan_const(pTHX_ char *start)
 	    }
 	    else {
 		didrange = FALSE;
+#ifdef EBCDIC
+		literal_endpoint = 0;
+#endif
 	    }
 	}
 
@@ -1555,9 +1602,9 @@ S_scan_const(pTHX_ char *start)
 		/* FALL THROUGH */
 	    default:
 	        {
-		    if (ckWARN(WARN_MISC) &&
-			isALNUM(*s) &&
-			*s != '_')
+		    if (isALNUM(*s) &&
+			*s != '_' &&
+			ckWARN(WARN_MISC))
 			Perl_warner(aTHX_ packWARN(WARN_MISC),
 			       "Unrecognized escape \\%c passed through",
 			       *s);
@@ -1788,6 +1835,10 @@ S_scan_const(pTHX_ char *start)
 	    s++;
 	    continue;
 	} /* end if (backslash) */
+#ifdef EBCDIC
+	else
+	    literal_endpoint++;
+#endif
 
     default_action:
 	/* If we started with encoded form, or already know we want it
@@ -2279,6 +2330,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",
@@ -3479,8 +3554,8 @@ Perl_yylex(pTHX)
 	    AOPERATOR(ANDAND);
 	s--;
 	if (PL_expect == XOPERATOR) {
-	    if (ckWARN(WARN_SEMICOLON)
-		&& isIDFIRST_lazy_if(s,UTF) && PL_bufptr == PL_linestart)
+	    if (PL_bufptr == PL_linestart && ckWARN(WARN_SEMICOLON)
+		&& isIDFIRST_lazy_if(s,UTF))
 	    {
 		CopLINE_dec(PL_curcop);
 		Perl_warner(aTHX_ packWARN(WARN_SEMICOLON), PL_warn_nosemi);
@@ -3515,7 +3590,7 @@ Perl_yylex(pTHX)
 	    OPERATOR(',');
 	if (tmp == '~')
 	    PMop(OP_MATCH);
-	if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
+	if (tmp && isSPACE(*s) && ckWARN(WARN_SYNTAX) && strchr("+-*/%.^&|<",tmp))
 	    Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Reversed %c= operator",(int)tmp);
 	s--;
 	if (PL_expect == XSTATE && isALPHA(tmp) &&
@@ -3685,8 +3760,8 @@ Perl_yylex(pTHX)
 	    else if (*s == '{') {
 		char *t;
 		PL_tokenbuf[0] = '%';
-		if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
-		    (t = strchr(s, '}')) && (t = strchr(t, '=')))
+		if (strEQ(PL_tokenbuf+1, "SIG")  && ckWARN(WARN_SYNTAX)
+		    && (t = strchr(s, '}')) && (t = strchr(t, '=')))
 		{
 		    char tmpbuf[sizeof PL_tokenbuf];
 		    for (t++; isSPACE(*t); t++) ;
@@ -3766,8 +3841,8 @@ Perl_yylex(pTHX)
 		PL_tokenbuf[0] = '%';
 
 	    /* Warn about @ where they meant $. */
-	    if (ckWARN(WARN_SYNTAX)) {
-		if (*s == '[' || *s == '{') {
+	    if (*s == '[' || *s == '{') {
+		if (ckWARN(WARN_SYNTAX)) {
 		    const char *t = s + 1;
 		    while (*t && (isALNUM_lazy_if(t,UTF) || strchr(" \t$#+-'\"", *t)))
 			t++;
@@ -3920,7 +3995,7 @@ Perl_yylex(pTHX)
 
     case '\\':
 	s++;
-	if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
+	if (PL_lex_inwhat && isDIGIT(*s) && ckWARN(WARN_SYNTAX))
 	    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),"Can't use \\%c to mean $%c in expression",
 			*s, *s);
 	if (PL_expect == XOPERATOR)
@@ -4081,8 +4156,8 @@ Perl_yylex(pTHX)
 		}
 		gv = Nullgv;
 		gvp = 0;
-		if (ckWARN(WARN_AMBIGUOUS) && hgv
-		    && tmp != KEY_x && tmp != KEY_CORE)	/* never ambiguous */
+		if (hgv && tmp != KEY_x && tmp != KEY_CORE
+			&& ckWARN(WARN_AMBIGUOUS))	/* never ambiguous */
 		    Perl_warner(aTHX_ packWARN(WARN_AMBIGUOUS),
 		    	"Ambiguous call resolved as CORE::%s(), %s",
 			 GvENAME(hgv), "qualify as such or use &");
@@ -4300,8 +4375,8 @@ Perl_yylex(pTHX)
 		    yylval.opval->op_private |= OPpCONST_STRICT;
 		else {
 		bareword:
-		    if (ckWARN(WARN_RESERVED)) {
-			if (lastchar != '-') {
+		    if (lastchar != '-') {
+			if (ckWARN(WARN_RESERVED)) {
 			    for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
 			    if (!*d && !gv_stashpv(PL_tokenbuf,FALSE))
 				Perl_warner(aTHX_ packWARN(WARN_RESERVED), PL_warn_reserved,
@@ -4445,6 +4520,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)
+		    /* that's a way to remember we saw "CORE::" */
+		    orig_keyword = KEY_require;
 		goto reserved_word;
 	    }
 	    goto just_a_word;
@@ -4857,11 +4935,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:
@@ -5030,7 +5104,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);
@@ -5393,25 +5478,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:
@@ -9085,7 +9152,7 @@ S_scan_ident(pTHX_ register char *s, register const char *send, char *dest, STRL
 {
     register char *d;
     register char *e;
-    char *bracket = 0;
+    char *bracket = Nullch;
     char funny = *s++;
 
     if (isSPACE(*s))
@@ -9263,7 +9330,7 @@ S_scan_pat(pTHX_ char *start, I32 type)
     char *s = scan_str(start,FALSE,FALSE);
 
     if (!s) {
-	char *delimiter = skipspace(start);
+	char * const delimiter = skipspace(start);
 	Perl_croak(aTHX_ *delimiter == '?'
 		   ? "Search pattern not terminated or ternary operator parsed as search pattern"
 		   : "Search pattern not terminated" );
@@ -9281,8 +9348,8 @@ S_scan_pat(pTHX_ char *start, I32 type)
 	    pmflag(&pm->op_pmflags,*s++);
     }
     /* issue a warning if /c is specified,but /g is not */
-    if (ckWARN(WARN_REGEXP) &&
-        (pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL))
+    if ((pm->op_pmflags & PMf_CONTINUE) && !(pm->op_pmflags & PMf_GLOBAL)
+	    && ckWARN(WARN_REGEXP))
     {
         Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_without_g);
     }
@@ -9337,7 +9404,7 @@ S_scan_subst(pTHX_ char *start)
     }
 
     /* /c is not meaningful with s/// */
-    if (ckWARN(WARN_REGEXP) && (pm->op_pmflags & PMf_CONTINUE))
+    if ((pm->op_pmflags & PMf_CONTINUE) && ckWARN(WARN_REGEXP))
     {
         Perl_warner(aTHX_ packWARN(WARN_REGEXP), c_in_subst);
     }
@@ -10223,7 +10290,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
 
 		/* _ are ignored -- but warned about if consecutive */
 		case '_':
-		    if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
+		    if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
 		        Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 				    "Misplaced _ in number");
 		    lastub = s++;
@@ -10303,7 +10370,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
 
 	    sv = NEWSV(92,0);
 	    if (overflowed) {
-		if (ckWARN(WARN_PORTABLE) && n > 4294967295.0)
+		if (n > 4294967295.0 && ckWARN(WARN_PORTABLE))
 		    Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
 				"%s number > %s non-portable",
 				Base, max);
@@ -10311,7 +10378,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
 	    }
 	    else {
 #if UVSIZE > 4
-		if (ckWARN(WARN_PORTABLE) && u > 0xffffffff)
+		if (u > 0xffffffff && ckWARN(WARN_PORTABLE))
 		    Perl_warner(aTHX_ packWARN(WARN_PORTABLE),
 				"%s number > %s non-portable",
 				Base, max);
@@ -10343,7 +10410,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
 	       if -w is on
 	    */
 	    if (*s == '_') {
-		if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
+		if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
 		    Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 				"Misplaced _ in number");
 		lastub = s++;
@@ -10385,7 +10452,7 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
 		if (d >= e)
 		    Perl_croak(aTHX_ number_too_long);
 		if (*s == '_') {
-		   if (ckWARN(WARN_SYNTAX) && lastub && s == lastub + 1)
+		   if (lastub && s == lastub + 1 && ckWARN(WARN_SYNTAX))
 		       Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 				   "Misplaced _ in number");
 		   lastub = s;
@@ -10442,9 +10509,9 @@ Perl_scan_num(pTHX_ const char *start, YYSTYPE* lvalp)
 		    *d++ = *s++;
 		}
 		else {
-		   if (ckWARN(WARN_SYNTAX) &&
-		       ((lastub && s == lastub + 1) ||
-			(!isDIGIT(s[1]) && s[1] != '_')))
+		   if (((lastub && s == lastub + 1) ||
+			(!isDIGIT(s[1]) && s[1] != '_'))
+	   	    && ckWARN(WARN_SYNTAX))
 		       Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
 				   "Misplaced _ in number");
 		   lastub = s++;