5.6.0 Patch for EPOC

[p5sagit/p5-mst-13.2.git] / toke.c

diff --git a/toke.c b/toke.c
index 70a7f53..d6bb6d9 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -326,7 +326,7 @@ S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 }
 #endif
 
-#if 0
+#ifdef PERL_UTF16_FILTER
 STATIC I32
 S_utf16_textfilter(pTHX_ int idx, SV *sv, int maxlen)
 {
@@ -987,6 +987,8 @@ S_sublex_start(pTHX)
 
            p = SvPV(sv, len);
            nsv = newSVpvn(p, len);
+            if (SvUTF8(sv))
+               SvUTF8_on(nsv);
            SvREFCNT_dec(sv);
            sv = nsv;
        } 
@@ -1390,7 +1392,7 @@ S_scan_const(pTHX_ char *start)
            default:
                {
                    dTHR;
-                   if (ckWARN(WARN_MISC) && isALNUM(*s))
+                   if (ckWARN(WARN_MISC) && isALNUM(*s) && *s != '_')
                        Perl_warner(aTHX_ WARN_MISC, 
                               "Unrecognized escape \\%c passed through",
                               *s);
@@ -2004,6 +2006,29 @@ 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)
+{
+    GV *gv;
+
+    if (*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:: */
+    }
+
+    /* use constant CLASS => 'MyClass' */
+    if ((gv = gv_fetchpv(pkgname, FALSE, SVt_PVCV))) {
+        SV *sv;
+        if (GvCV(gv) && (sv = cv_const_sv(GvCV(gv)))) {
+            pkgname = SvPV_nolen(sv);
+        }
+    }
+
+    return gv_stashpv(pkgname, FALSE);
+}
 
 #ifdef DEBUGGING
     static char* exp_name[] =
@@ -2465,6 +2490,8 @@ 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) {
              fake_eof:
                if (PL_rsfp) {
@@ -2500,7 +2527,9 @@ Perl_yylex(pTHX)
                    PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
                    PL_doextract = FALSE;
                }
-           }
+           } 
+        if (bof)
+            s = swallow_bom(s);
            incline(s);
        } while (PL_doextract);
        PL_oldoldbufptr = PL_oldbufptr = PL_bufptr = PL_linestart = s;
@@ -4408,7 +4437,7 @@ Perl_yylex(pTHX)
                s = scan_word(s, PL_tokenbuf, sizeof PL_tokenbuf, TRUE, &len);
                if (len == 3 && strnEQ(PL_tokenbuf, "sub", 3))
                    goto really_sub;
-               PL_in_my_stash = gv_stashpv(PL_tokenbuf, FALSE);
+               PL_in_my_stash = find_in_my_stash(PL_tokenbuf, len);
                if (!PL_in_my_stash) {
                    char tmpbuf[1024];
                    PL_bufptr = s;
@@ -6128,45 +6157,20 @@ S_scan_trans(pTHX_ char *start)
        Perl_croak(aTHX_ "Transliteration replacement not terminated");
     }
 
-    if (UTF) {
-       o = newSVOP(OP_TRANS, 0, 0);
-       utf8 = OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF;
-    }
-    else {
        New(803,tbl,256,short);
        o = newPVOP(OP_TRANS, 0, (char*)tbl);
-       utf8 = 0;
-    }
 
     complement = del = squash = 0;
-    while (strchr("cdsCU", *s)) {
+    while (strchr("cds", *s)) {
        if (*s == 'c')
            complement = OPpTRANS_COMPLEMENT;
        else if (*s == 'd')
            del = OPpTRANS_DELETE;
        else if (*s == 's')
            squash = OPpTRANS_SQUASH;
-       else {
-           switch (count++) {
-           case 0:
-               if (*s == 'C')
-                   utf8 &= ~OPpTRANS_FROM_UTF;
-               else
-                   utf8 |= OPpTRANS_FROM_UTF;
-               break;
-           case 1:
-               if (*s == 'C')
-                   utf8 &= ~OPpTRANS_TO_UTF;
-               else
-                   utf8 |= OPpTRANS_TO_UTF;
-               break;
-           default: 
-               Perl_croak(aTHX_ "Too many /C and /U options");
-           }
-       }
        s++;
     }
-    o->op_private = del|squash|complement|utf8;
+    o->op_private = del|squash|complement;
 
     PL_lex_op = o;
     yylval.ival = OP_TRANS;
@@ -7407,3 +7411,55 @@ restore_rsfp(pTHXo_ void *f)
        PerlIO_close(PL_rsfp);
     PL_rsfp = fp;
 }
+
+STATIC char*
+S_swallow_bom(pTHX_ char *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;
+#else
+        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;
+#else
+        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;
+}