X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=toke.c;h=a4f95a7e98ada25a17a696f6de90554fba4b4201;hb=e5c81feb3d32a96869ed78abc5cecef7e294da38;hp=b3120506759a7d4a309877e27c14974e46e8dcec;hpb=0ba2ce2152b6dd32dce213e5000623f16b2f39eb;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/toke.c b/toke.c
index b312050..a4f95a7 100644
--- a/toke.c
+++ b/toke.c
@@ -28,6 +28,10 @@
 static char ident_too_long[] = "Identifier too long";
 
 static void restore_rsfp(pTHXo_ void *f);
+#ifndef PERL_NO_UTF16_FILTER
+static I32 utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen);
+static I32 utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen);
+#endif
 
 #define XFAKEBRACK 128
 #define XENUMMASK 127
@@ -326,36 +330,6 @@ S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 }
 #endif
 
-#ifdef PERL_UTF16_FILTER
-STATIC I32
-S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
-{
-    I32 count = FILTER_READ(idx+1, sv, maxlen);
-    if (count) {
-	U8* tmps;
-	U8* tend;
-	New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
-	tend = utf16_to_utf8((U16*)SvPVX(sv), tmps, SvCUR(sv));
-	sv_usepvn(sv, (char*)tmps, tend - tmps);
-    }
-    return count;
-}
-
-STATIC I32
-S_utf16rev_textfilter(pTHX_ int idx, SV *sv, int maxlen)
-{
-    I32 count = FILTER_READ(idx+1, sv, maxlen);
-    if (count) {
-	U8* tmps;
-	U8* tend;
-	New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
-	tend = utf16_to_utf8_reversed((U16*)SvPVX(sv), tmps, SvCUR(sv));
-	sv_usepvn(sv, (char*)tmps, tend - tmps);
-    }
-    return count;
-}
-#endif
-
 /*
  * Perl_lex_start
  * Initialize variables.  Uses the Perl save_stack to save its state (for
@@ -987,8 +961,8 @@ S_sublex_start(pTHX)
 
 	    p = SvPV(sv, len);
 	    nsv = newSVpvn(p, len);
-            if (SvUTF8(sv))
-               SvUTF8_on(nsv);
+	    if (SvUTF8(sv))
+		SvUTF8_on(nsv);
 	    SvREFCNT_dec(sv);
 	    sv = nsv;
 	} 
@@ -1242,11 +1216,10 @@ S_scan_const(pTHX_ char *start)
 		min = (U8)*d;			/* first char in range */
 		max = (U8)d[1];			/* last char in range  */
 
-
                 if (min > max) {
-                    Perl_croak(aTHX_
-                           "Invalid [] range \"%c-%c\" in transliteration operator",
-                           min, max);
+		    Perl_croak(aTHX_
+			       "Invalid [] range \"%c-%c\" in transliteration operator",
+			       min, max);
                 }
 
 #ifndef ASCIIish
@@ -1269,15 +1242,15 @@ S_scan_const(pTHX_ char *start)
 
 		/* mark the range as done, and continue */
 		dorange = FALSE;
-                didrange = TRUE;
+		didrange = TRUE;
 		continue;
 	    } 
 
 	    /* range begins (ignore - as first or last char) */
 	    else if (*s == '-' && s+1 < send  && s != start) {
-                if (didrange) { 
+		if (didrange) { 
 		    Perl_croak(aTHX_ "Ambiguous range in transliteration operator");
-                }
+		}
 		if (utf) {
 		    *d++ = (char)0xff;	/* use illegal utf8 byte--see pmtrans */
 		    s++;
@@ -1285,9 +1258,10 @@ S_scan_const(pTHX_ char *start)
 		}
 		dorange = TRUE;
 		s++;
-	    } else {
-              didrange = FALSE;
-            }
+	    }
+	    else {
+		didrange = FALSE;
+	    }
 	}
 
 	/* if we get here, we're not doing a transliteration */
@@ -1406,7 +1380,7 @@ S_scan_const(pTHX_ char *start)
 	    default:
 	        {
 		    dTHR;
-		    if (ckWARN(WARN_MISC) && isALNUM(*s) && *s != '_')
+		    if (ckWARN(WARN_MISC) && isALNUM(*s))
 			Perl_warner(aTHX_ WARN_MISC, 
 			       "Unrecognized escape \\%c passed through",
 			       *s);
@@ -2020,17 +1994,19 @@ S_filter_gets(pTHX_ register SV *sv, register PerlIO *fp, STRLEN append)
         return (sv_gets(sv, fp, append));
 }
 
-STATIC HV *S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
+STATIC HV *
+S_find_in_my_stash(pTHX_ char *pkgname, I32 len)
 {
     GV *gv;
 
-    if (*pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
+    if (len == 11 && *pkgname == '_' && strEQ(pkgname, "__PACKAGE__"))
         return PL_curstash;
 
     if (len > 2 &&
         (pkgname[len - 2] == ':' && pkgname[len - 1] == ':') &&
-        (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV))) {
-        return GvHV(gv); /* Foo:: */
+        (gv = gv_fetchpv(pkgname, FALSE, SVt_PVHV)))
+    {
+        return GvHV(gv);			/* Foo:: */
     }
 
     /* use constant CLASS => 'MyClass' */
@@ -2504,9 +2480,10 @@ Perl_yylex(pTHX)
 	    goto retry;
 	}
 	do {
-        bool bof;
-        bof = PL_rsfp && (PerlIO_tell(PL_rsfp)==0); /* *Before* read! */
-	    if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
+	    bool bof;
+	    bof = PL_rsfp && (PerlIO_tell(PL_rsfp) == 0); /* *Before* read! */
+	    s = filter_gets(PL_linestr, PL_rsfp, 0);
+	    if (s == Nullch) {
 	      fake_eof:
 		if (PL_rsfp) {
 		    if (PL_preprocess && !PL_in_eval)
@@ -2529,6 +2506,9 @@ Perl_yylex(pTHX)
 		PL_oldoldbufptr = PL_oldbufptr = s = PL_linestart = SvPVX(PL_linestr);
 		sv_setpv(PL_linestr,"");
 		TOKEN(';');	/* not infinite loop because rsfp is NULL now */
+	    } else if (bof) {
+		PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
+		s = swallow_bom((U8*)s);
 	    }
 	    if (PL_doextract) {
 		if (*s == '#' && s[1] == '!' && instr(s,"perl"))
@@ -2542,8 +2522,6 @@ Perl_yylex(pTHX)
 		    PL_doextract = FALSE;
 		}
 	    } 
-        if (bof)
-            s = swallow_bom(s);
 	    incline(s);
 	} while (PL_doextract);
 	PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
@@ -4002,11 +3980,11 @@ Perl_yylex(pTHX)
 		/* Mark this internal pseudo-handle as clean */
 		IoFLAGS(GvIOp(gv)) |= IOf_UNTAINT;
 		if (PL_preprocess)
-		    IoTYPE(GvIOp(gv)) = '|';
+		    IoTYPE(GvIOp(gv)) = IoTYPE_PIPE;
 		else if ((PerlIO*)PL_rsfp == PerlIO_stdin())
-		    IoTYPE(GvIOp(gv)) = '-';
+		    IoTYPE(GvIOp(gv)) = IoTYPE_STD;
 		else
-		    IoTYPE(GvIOp(gv)) = '<';
+		    IoTYPE(GvIOp(gv)) = IoTYPE_RDONLY;
 #if defined(WIN32) && !defined(PERL_TEXTMODE_SCRIPTS)
 		/* if the script was opened in binmode, we need to revert
 		 * it to text mode for compatibility; but only iff it has CRs
@@ -4015,7 +3993,7 @@ Perl_yylex(pTHX)
 		    && PL_bufend[-1] == '\n' && PL_bufend[-2] == '\r')
 		{
 		    Off_t loc = 0;
-		    if (IoTYPE(GvIOp(gv)) == '<') {
+		    if (IoTYPE(GvIOp(gv)) == IoTYPE_RDONLY) {
 			loc = PerlIO_tell(PL_rsfp);
 			(void)PerlIO_seek(PL_rsfp, 0L, 0);
 		    }
@@ -5164,7 +5142,6 @@ Perl_keyword(pTHX_ register char *d, I32 len)
 	}
 	break;
     case 'E':
-	if (strEQ(d,"EQ")) { deprecate(d);	return -KEY_eq;}
 	if (strEQ(d,"END"))			return KEY_END;
 	break;
     case 'e':
@@ -5230,12 +5207,6 @@ Perl_keyword(pTHX_ register char *d, I32 len)
 	    break;
 	}
 	break;
-    case 'G':
-	if (len == 2) {
-	    if (strEQ(d,"GT")) { deprecate(d);	return -KEY_gt;}
-	    if (strEQ(d,"GE")) { deprecate(d);	return -KEY_ge;}
-	}
-	break;
     case 'g':
 	if (strnEQ(d,"get",3)) {
 	    d += 3;
@@ -5335,12 +5306,6 @@ Perl_keyword(pTHX_ register char *d, I32 len)
 	    if (strEQ(d,"kill"))		return -KEY_kill;
 	}
 	break;
-    case 'L':
-	if (len == 2) {
-	    if (strEQ(d,"LT")) { deprecate(d);	return -KEY_lt;}
-	    if (strEQ(d,"LE")) { deprecate(d);	return -KEY_le;}
-	}
-	break;
     case 'l':
 	switch (len) {
 	case 2:
@@ -5392,9 +5357,6 @@ Perl_keyword(pTHX_ register char *d, I32 len)
 	    break;
 	}
 	break;
-    case 'N':
-	if (strEQ(d,"NE")) { deprecate(d);	return -KEY_ne;}
-	break;
     case 'n':
 	if (strEQ(d,"next"))			return KEY_next;
 	if (strEQ(d,"ne"))			return -KEY_ne;
@@ -6171,8 +6133,8 @@ S_scan_trans(pTHX_ char *start)
 	Perl_croak(aTHX_ "Transliteration replacement not terminated");
     }
 
-	New(803,tbl,256,short);
-	o = newPVOP(OP_TRANS, 0, (char*)tbl);
+    New(803,tbl,256,short);
+    o = newPVOP(OP_TRANS, 0, (char*)tbl);
 
     complement = del = squash = 0;
     while (strchr("cds", *s)) {
@@ -7404,57 +7366,79 @@ Perl_yyerror(pTHX_ char *s)
     return 0;
 }
 
-
 STATIC char*
-S_swallow_bom(pTHX_ char *s) {
+S_swallow_bom(pTHX_ U8 *s)
+{
     STRLEN slen;
     slen = SvCUR(PL_linestr);
     switch (*s) {
-    case -1:       
-    if ((s[1] & 255) == 254) { 
-        /* UTF-16 little-endian */
-#ifdef PERL_UTF16_FILTER
-        U8 *news;
-#endif
-        s+=2;
-        if (*s == 0 && s[1] == 0)  /* UTF-32 little-endian */
-            Perl_croak(aTHX_ "Unsupported script encoding");
-#ifdef PERL_UTF16_FILTER
-        filter_add(S_utf16rev_textfilter, NULL);
-        New(898, news, (PL_bufend - s) * 3 / 2 + 1, U8);
-        PL_bufend = utf16_to_utf8((U16*)s, news, PL_bufend - s);
-        s = news;
+    case 0xFF:       
+	if (s[1] == 0xFE) { 
+	    /* UTF-16 little-endian */
+	    if (s[2] == 0 && s[3] == 0)  /* UTF-32 little-endian */
+		Perl_croak(aTHX_ "Unsupported script encoding");
+#ifndef PERL_NO_UTF16_FILTER
+	    DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-LE script encoding\n"));
+	    s += 2;
+	    if (PL_bufend > (char*)s) {
+		U8 *news;
+		I32 newlen;
+
+		filter_add(utf16rev_textfilter, NULL);
+		New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
+		PL_bufend = (char*)utf16_to_utf8_reversed(s, news,
+						 PL_bufend - (char*)s - 1,
+						 &newlen);
+		Copy(news, s, newlen, U8);
+		SvCUR_set(PL_linestr, newlen);
+		PL_bufend = SvPVX(PL_linestr) + newlen;
+		news[newlen++] = '\0';
+		Safefree(news);
+	    }
 #else
-        Perl_croak(aTHX_ "Unsupported script encoding");
+	    Perl_croak(aTHX_ "Unsupported script encoding");
 #endif
-    }
-    break;
-
-    case -2:
-    if ((s[1] & 255) == 255) {   /* UTF-16 big-endian */
-#ifdef PERL_UTF16_FILTER
-        U8 *news;
-        filter_add(S_utf16_textfilter, NULL);
-        New(898, news, (PL_bufend - s) * 3 / 2 + 1, U8);
-        PL_bufend = utf16_to_utf8((U16*)s, news, PL_bufend - s);
-        s = news;
+	}
+	break;
+    case 0xFE:
+	if (s[1] == 0xFF) {   /* UTF-16 big-endian */
+#ifndef PERL_NO_UTF16_FILTER
+	    DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-16BE script encoding\n"));
+	    s += 2;
+	    if (PL_bufend > (char *)s) {
+		U8 *news;
+		I32 newlen;
+
+		filter_add(utf16_textfilter, NULL);
+		New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
+		PL_bufend = (char*)utf16_to_utf8(s, news,
+						 PL_bufend - (char*)s,
+						 &newlen);
+		Copy(news, s, newlen, U8);
+		SvCUR_set(PL_linestr, newlen);
+		PL_bufend = SvPVX(PL_linestr) + newlen;
+		news[newlen++] = '\0';
+		Safefree(news);
+	    }
 #else
-        Perl_croak(aTHX_ "Unsupported script encoding");
+	    Perl_croak(aTHX_ "Unsupported script encoding");
 #endif
-   }
-   break;
-
-   case -17:
-   if ( slen>2 && (s[1] & 255) == 187 && (s[2] & 255) == 191) {
-        s+=3;                      /* UTF-8 */
-   }
-   break;
-   case 0:
-   if (slen > 3 && s[1] == 0 &&  /* UTF-32 big-endian */
-       s[2] & 255 == 254 && s[3] & 255 == 255)
-       Perl_croak(aTHX_ "Unsupported script encoding");
-} 
-return s;
+	}
+	break;
+    case 0xEF:
+	if (slen > 2 && s[1] == 0xBB && s[2] == 0xBF) {
+	    DEBUG_p(PerlIO_printf(Perl_debug_log, "UTF-8 script encoding\n"));
+	    s += 3;                      /* UTF-8 */
+	}
+	break;
+    case 0:
+	if (slen > 3 && s[1] == 0 &&  /* UTF-32 big-endian */
+	    s[2] == 0xFE && s[3] == 0xFF)
+	{
+	    Perl_croak(aTHX_ "Unsupported script encoding");
+	}
+    }
+    return (char*)s;
 }
 
 #ifdef PERL_OBJECT
@@ -7477,3 +7461,43 @@ restore_rsfp(pTHXo_ void *f)
 	PerlIO_close(PL_rsfp);
     PL_rsfp = fp;
 }
+
+#ifndef PERL_NO_UTF16_FILTER
+static I32
+utf16_textfilter(pTHXo_ int idx, SV *sv, int maxlen)
+{
+    I32 count = FILTER_READ(idx+1, sv, maxlen);
+    if (count) {
+	U8* tmps;
+	U8* tend;
+	I32 newlen;
+	New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
+	if (!*SvPV_nolen(sv))
+	/* Game over, but don't feed an odd-length string to utf16_to_utf8 */
+	return count;
+       
+	tend = utf16_to_utf8((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
+	sv_usepvn(sv, (char*)tmps, tend - tmps);
+    }
+    return count;
+}
+
+static I32
+utf16rev_textfilter(pTHXo_ int idx, SV *sv, int maxlen)
+{
+    I32 count = FILTER_READ(idx+1, sv, maxlen);
+    if (count) {
+	U8* tmps;
+	U8* tend;
+	I32 newlen;
+	if (!*SvPV_nolen(sv))
+	/* Game over, but don't feed an odd-length string to utf16_to_utf8 */
+	return count;
+
+	New(898, tmps, SvCUR(sv) * 3 / 2 + 1, U8);
+	tend = utf16_to_utf8_reversed((U8*)SvPVX(sv), tmps, SvCUR(sv), &newlen);
+	sv_usepvn(sv, (char*)tmps, tend - tmps);
+    }
+    return count;
+}
+#endif