X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=10273a01115901057e55da0ea6945db3d4dfb8f3;hb=9bc5fa8de0e98ff1317c3fdc7e35f6e13be0ac35;hp=c5637d3b315dfc76607b242f8550c8f864a7b6a2;hpb=8341b96b912f641681f822ceb6ec0b8b19720375;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/toke.c b/toke.c
index c5637d3..10273a0 100644
--- a/toke.c
+++ b/toke.c
@@ -1377,7 +1377,7 @@ S_scan_const(pTHX_ char *start)
 	    default:
 	        {
 		    dTHR;
-		    if (ckWARN(WARN_MISC) && isALPHA(*s))
+		    if (ckWARN(WARN_MISC) && isALNUM(*s))
 			Perl_warner(aTHX_ WARN_MISC, 
 			       "Unrecognized escape \\%c passed through",
 			       *s);
@@ -1389,6 +1389,7 @@ S_scan_const(pTHX_ char *start)
 	    /* \132 indicates an octal constant */
 	    case '0': case '1': case '2': case '3':
 	    case '4': case '5': case '6': case '7':
+		len = 0;	/* disallow underscores */
 		uv = (UV)scan_oct(s, 3, &len);
 		s += len;
 		goto NUM_ESCAPE_INSERT;
@@ -1402,10 +1403,12 @@ S_scan_const(pTHX_ char *start)
 			yyerror("Missing right brace on \\x{}");
 			e = s;
 		    }
+		    len = 1;		/* allow underscores */
                     uv = (UV)scan_hex(s + 1, e - s - 1, &len);
                     s = e + 1;
 		}
 		else {
+		    len = 0;		/* disallow underscores */
 		    uv = (UV)scan_hex(s, 2, &len);
 		    s += len;
 		}
@@ -1479,8 +1482,14 @@ S_scan_const(pTHX_ char *start)
 		    res = new_constant( Nullch, 0, "charnames", 
 					res, Nullsv, "\\N{...}" );
 		    str = SvPV(res,len);
-		    if (len > 1)
+		    if (!has_utf && SvUTF8(res)) {
+			char *ostart = SvPVX(sv);
+			SvCUR_set(sv, d - ostart);
+			SvPOK_on(sv);
+			sv_utf8_upgrade(sv);
+			d = SvPVX(sv) + SvCUR(sv);
 			has_utf = TRUE;
+		    }
 		    if (len > e - s + 4) {
 			char *odest = SvPVX(sv);
 
@@ -1504,7 +1513,8 @@ S_scan_const(pTHX_ char *start)
 		*d = *s++;
 		if (isLOWER(*d))
 		   *d = toUPPER(*d);
-		*d++ = toCTRL(*d); 
+		*d = toCTRL(*d); 
+		d++;
 #else
 		len = *s++;
 		*d++ = toCTRL(len);
@@ -2641,7 +2651,7 @@ Perl_yylex(pTHX)
 #ifdef PERL_STRICT_CR
 	Perl_warn(aTHX_ "Illegal character \\%03o (carriage return)", '\r');
 	Perl_croak(aTHX_ 
-      "(Maybe you didn't strip carriage returns after a network transfer?)\n");
+      "\t(Maybe you didn't strip carriage returns after a network transfer?)\n");
 #endif
     case ' ': case '\t': case '\f': case 013:
 	s++;
@@ -2649,6 +2659,11 @@ Perl_yylex(pTHX)
     case '#':
     case '\n':
 	if (PL_lex_state != LEX_NORMAL || (PL_in_eval && !PL_rsfp)) {
+	    if (*s == '#' && s == PL_linestart && PL_in_eval && !PL_rsfp) {
+		/* handle eval qq[#line 1 "foo"\n ...] */
+		CopLINE_dec(PL_curcop);
+		incline(s);
+	    }
 	    d = PL_bufend;
 	    while (s < d && *s != '\n')
 		s++;
@@ -3612,7 +3627,7 @@ Perl_yylex(pTHX)
 	tmp = keyword(PL_tokenbuf, len);
 
 	/* Is this a word before a => operator? */
-	if (strnEQ(d,"=>",2)) {
+	if (*d == '=' && d[1] == '>') {
 	    CLINE;
 	    yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(PL_tokenbuf,0));
 	    yylval.opval->op_private = OPpCONST_BARE;
@@ -3767,10 +3782,18 @@ Perl_yylex(pTHX)
 		    }
 		}
 
-		/* If followed by a paren, it's certainly a subroutine. */
 
 		PL_expect = XOPERATOR;
 		s = skipspace(s);
+
+		/* Is this a word before a => operator? */
+		if (*s == '=' && s[1] == '>') {
+		    CLINE;
+		    sv_setpv(((SVOP*)yylval.opval)->op_sv, PL_tokenbuf);
+		    TERM(WORD);
+		}
+
+		/* If followed by a paren, it's certainly a subroutine. */
 		if (*s == '(') {
 		    CLINE;
 		    if (gv && GvCVu(gv)) {
@@ -4489,7 +4512,7 @@ Perl_yylex(pTHX)
 			    for (; !isSPACE(*d) && len; --len, ++d) ;
 			}
 			words = append_elem(OP_LIST, words,
-					    newSVOP(OP_CONST, 0, newSVpvn(b, d-b)));
+					    newSVOP(OP_CONST, 0, tokeq(newSVpvn(b, d-b))));
 		    }
 		}
 		if (words) {
@@ -5648,30 +5671,28 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
     SV *res;
     SV **cvp;
     SV *cv, *typesv;
-    const char *why, *why1, *why2;
+    const char *why1, *why2, *why3;
     
-    if (!(PL_hints & HINT_LOCALIZE_HH)) {
+    if (!table || !(PL_hints & HINT_LOCALIZE_HH)) {
 	SV *msg;
 	
-	why = "%^H is not localized";
-    report_short:
-	why1 = why2 = "";
+	why1 = "%^H is not consistent";
+	why2 = strEQ(key,"charnames")
+	       ? " (missing \"use charnames ...\"?)"
+	       : "";
+	why3 = "";
     report:
 	msg = Perl_newSVpvf(aTHX_ "constant(%s): %s%s%s", 
-			    (type ? type: "undef"), why1, why2, why);
+			    (type ? type: "undef"), why1, why2, why3);
 	yyerror(SvPVX(msg));
  	SvREFCNT_dec(msg);
   	return sv;
     }
-    if (!table) {
-	why = "%^H is not defined";
-	goto report_short;
-    }
     cvp = hv_fetch(table, key, strlen(key), FALSE);
     if (!cvp || !SvOK(*cvp)) {
-	why = "} is not defined";
 	why1 = "$^H{";
 	why2 = key;
+	why3 = "} is not defined";
 	goto report;
     }
     sv_2mortal(sv);			/* Parent created it permanently */
@@ -5719,9 +5740,9 @@ S_new_constant(pTHX_ char *s, STRLEN len, const char *key, SV *sv, SV *pv,
     POPSTACK;
     
     if (!SvOK(res)) {
- 	why = "}} did not return a defined value";
  	why1 = "Call to &{$^H{";
  	why2 = key;
+ 	why3 = "}} did not return a defined value";
  	sv = res;
  	goto report;
     }