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

diff --git a/toke.c b/toke.c
index 2e6120d..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,6 +1482,14 @@ S_scan_const(pTHX_ char *start)
 		    res = new_constant( Nullch, 0, "charnames", 
 					res, Nullsv, "\\N{...}" );
 		    str = SvPV(res,len);
+		    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);
 
@@ -1502,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);
@@ -2639,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++;
@@ -2647,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++;
@@ -3276,7 +3293,7 @@ Perl_yylex(pTHX)
 	/* This kludge not intended to be bulletproof. */
 	if (PL_tokenbuf[1] == '[' && !PL_tokenbuf[2]) {
 	    yylval.opval = newSVOP(OP_CONST, 0,
-				   newSViv((IV)PL_compiling.cop_arybase));
+				   newSViv(PL_compiling.cop_arybase));
 	    yylval.opval->op_private = OPpCONST_ARYBASE;
 	    TERM(THING);
 	}
@@ -3610,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;
@@ -3765,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)) {
@@ -3958,7 +3983,8 @@ Perl_yylex(pTHX)
 		s += 2;
 		d = s;
 		s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, FALSE, &len);
-		tmp = keyword(PL_tokenbuf, len);
+		if (!(tmp = keyword(PL_tokenbuf, len)))
+		    Perl_croak(aTHX_ "CORE::%s is not a keyword", PL_tokenbuf);
 		if (tmp < 0)
 		    tmp = -tmp;
 		goto reserved_word;
@@ -4486,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) {
@@ -5645,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 */
@@ -5716,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;
     }
@@ -6982,9 +7006,9 @@ Perl_scan_num(pTHX_ char *start)
     	    UV uv;
 	    errno = 0;
 	    if (*PL_tokenbuf == '-')
-		iv = Atol(PL_tokenbuf);
+		iv = Strtol(PL_tokenbuf, (char**)NULL, 10);
 	    else
-		uv = Atoul(PL_tokenbuf);
+		uv = Strtoul(PL_tokenbuf, (char**)NULL, 10);
 	    if (errno)
 	    	floatit = TRUE; /* probably just too large */
 	    else if (*PL_tokenbuf == '-')
@@ -6993,14 +7017,9 @@ Perl_scan_num(pTHX_ char *start)
 	    	sv_setuv(sv, uv);
 	}
 	if (floatit) {
-	    char *tp;
-	    errno = 0;
 	    value = Atof(PL_tokenbuf);
-	    if (errno)
-		Perl_die(aTHX_ "unparseable float");
-	    else
-	    	sv_setnv(sv, value);
-	} 
+	    sv_setnv(sv, value);
+	}
 #endif
 	if ( floatit ? (PL_hints & HINT_NEW_FLOAT) :
 	               (PL_hints & HINT_NEW_INTEGER) )
@@ -7306,8 +7325,14 @@ Perl_yyerror(pTHX_ char *s)
 	Perl_warn(aTHX_ "%"SVf, msg);
     else
 	qerror(msg);
-    if (PL_error_count >= 10)
-	Perl_croak(aTHX_ "%s has too many errors.\n", CopFILE(PL_curcop));
+    if (PL_error_count >= 10) {
+	if (PL_in_eval && SvCUR(ERRSV))
+	    Perl_croak(aTHX_ "%_%s has too many errors.\n",
+		       ERRSV, CopFILE(PL_curcop));
+	else
+	    Perl_croak(aTHX_ "%s has too many errors.\n",
+		       CopFILE(PL_curcop));
+    }
     PL_in_my = 0;
     PL_in_my_stash = Nullhv;
     return 0;