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

diff --git a/toke.c b/toke.c
index e47853e..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
 
-#ifndef PERL_NO_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
@@ -2508,7 +2482,8 @@ Perl_yylex(pTHX)
 	do {
 	    bool bof;
 	    bof = PL_rsfp && (PerlIO_tell(PL_rsfp) == 0); /* *Before* read! */
-	    if ((s = filter_gets(PL_linestr, PL_rsfp, 0)) == Nullch) {
+	    s = filter_gets(PL_linestr, PL_rsfp, 0);
+	    if (s == Nullch) {
 	      fake_eof:
 		if (PL_rsfp) {
 		    if (PL_preprocess && !PL_in_eval)
@@ -2531,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"))
@@ -2544,8 +2522,6 @@ Perl_yylex(pTHX)
 		    PL_doextract = FALSE;
 		}
 	    } 
-	    if (bof)
-		s = swallow_bom((U8*)s);
 	    incline(s);
 	} while (PL_doextract);
 	PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
@@ -4004,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
@@ -4017,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);
 		    }
@@ -5166,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':
@@ -5232,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;
@@ -5337,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:
@@ -5394,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;
@@ -7415,18 +7375,26 @@ S_swallow_bom(pTHX_ U8 *s)
     case 0xFF:       
 	if (s[1] == 0xFE) { 
 	    /* UTF-16 little-endian */
-#ifndef PERL_NO_UTF16_FILTER
-	    U8 *news;
-#endif
 	    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;
-	    filter_add(S_utf16rev_textfilter, NULL);
-	    New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
-	    PL_bufend = (char*)utf16_to_utf8((U16*)s, news,
-					     PL_bufend - (char*)s);
-	    s = news;
+	    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");
 #endif
@@ -7435,12 +7403,23 @@ S_swallow_bom(pTHX_ U8 *s)
     case 0xFE:
 	if (s[1] == 0xFF) {   /* UTF-16 big-endian */
 #ifndef PERL_NO_UTF16_FILTER
-	    U8 *news;
-	    filter_add(S_utf16_textfilter, NULL);
-	    New(898, news, (PL_bufend - (char*)s) * 3 / 2 + 1, U8);
-	    PL_bufend = (char*)utf16_to_utf8((U16*)s, news,
-					     PL_bufend - (char*)s);
-	    s = news;
+	    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");
 #endif
@@ -7448,6 +7427,7 @@ S_swallow_bom(pTHX_ U8 *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;
@@ -7481,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