Integrate mainline

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

diff --git a/utf8.c b/utf8.c
index f16cb66..1b13809 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -24,6 +24,8 @@
 #define PERL_IN_UTF8_C
 #include "perl.h"
 
+static char unees[] = "Malformed UTF-8 character (unexpected end of string)";
+
 /* 
 =head1 Unicode Support
 
@@ -62,10 +64,7 @@ Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
                  ((uv >= 0xFDD0 && uv <= 0xFDEF &&
                    !(flags & UNICODE_ALLOW_FDD0))
                   ||
-                  ((uv & 0xFFFF) == 0xFFFE &&
-                   !(flags & UNICODE_ALLOW_FFFE))
-                  ||
-                  ((uv & 0xFFFF) == 0xFFFF &&
+                  ((uv & 0xFFFE) == 0xFFFE && /* Either FFFE or FFFF. */
                    !(flags & UNICODE_ALLOW_FFFF))) &&
                  /* UNICODE_ALLOW_SUPER includes
                   * FFFEs and FFFFs beyond 0x10FFFF. */
@@ -294,9 +293,8 @@ Perl_utf8n_to_uvuni(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
 #define UTF8_WARN_SHORT                                 5
 #define UTF8_WARN_OVERFLOW                      6
 #define UTF8_WARN_SURROGATE                     7
-#define UTF8_WARN_BOM                           8
-#define UTF8_WARN_LONG                          9
-#define UTF8_WARN_FFFF                         10
+#define UTF8_WARN_LONG                          8
+#define UTF8_WARN_FFFF                          9 /* Also FFFE. */
 
     if (curlen == 0 &&
        !(flags & UTF8_ALLOW_EMPTY)) {
@@ -391,10 +389,6 @@ Perl_utf8n_to_uvuni(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
        !(flags & UTF8_ALLOW_SURROGATE)) {
        warning = UTF8_WARN_SURROGATE;
        goto malformed;
-    } else if (UNICODE_IS_BYTE_ORDER_MARK(uv) &&
-              !(flags & UTF8_ALLOW_BOM)) {
-       warning = UTF8_WARN_BOM;
-       goto malformed;
     } else if ((expectlen > UNISKIP(uv)) &&
               !(flags & UTF8_ALLOW_LONG)) {
        warning = UTF8_WARN_LONG;
@@ -450,9 +444,6 @@ malformed:
        case UTF8_WARN_SURROGATE:
            Perl_sv_catpvf(aTHX_ sv, "(UTF-16 surrogate 0x%04"UVxf")", uv);
            break;
-       case UTF8_WARN_BOM:
-           Perl_sv_catpvf(aTHX_ sv, "(byte order mark 0x%04"UVxf")", uv);
-           break;
        case UTF8_WARN_LONG:
            Perl_sv_catpvf(aTHX_ sv, "(%d byte%s, need %d, after start byte 0x%02"UVxf")",
                           expectlen, expectlen == 1 ? "": "s", UNISKIP(uv), startbyte);
@@ -498,7 +489,8 @@ returned and retlen is set, if possible, to -1.
 UV
 Perl_utf8_to_uvchr(pTHX_ U8 *s, STRLEN *retlen)
 {
-    return Perl_utf8n_to_uvchr(aTHX_ s, UTF8_MAXLEN, retlen, 0);
+    return Perl_utf8n_to_uvchr(aTHX_ s, UTF8_MAXLEN, retlen,
+                              ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
 }
 
 /*
@@ -521,7 +513,8 @@ UV
 Perl_utf8_to_uvuni(pTHX_ U8 *s, STRLEN *retlen)
 {
     /* Call the low level routine asking for checks */
-    return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXLEN, retlen, 0);
+    return Perl_utf8n_to_uvuni(aTHX_ s, UTF8_MAXLEN, retlen,
+                              ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANY);
 }
 
 /*
@@ -543,13 +536,29 @@ Perl_utf8_length(pTHX_ U8 *s, U8 *e)
      * the bitops (especially ~) can create illegal UTF-8.
      * In other words: in Perl UTF-8 is not just for Unicode. */
 
-    if (e < s)
-       Perl_croak(aTHX_ "panic: utf8_length: unexpected end");
+    if (e < s) {
+        if (ckWARN_d(WARN_UTF8)) {
+           if (PL_op)
+               Perl_warner(aTHX_ packWARN(WARN_UTF8),
+                           "%s in %s", unees, OP_DESC(PL_op));
+           else
+               Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
+       }
+       return 0;
+    }
     while (s < e) {
        U8 t = UTF8SKIP(s);
 
-       if (e - s < t)
-           Perl_croak(aTHX_ "panic: utf8_length: unaligned end");
+       if (e - s < t) {
+           if (ckWARN_d(WARN_UTF8)) {
+               if (PL_op)
+                   Perl_warner(aTHX_ packWARN(WARN_UTF8),
+                               unees, OP_DESC(PL_op));
+               else
+                   Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
+           }
+           return len;
+       }
        s += t;
        len++;
     }
@@ -582,8 +591,16 @@ Perl_utf8_distance(pTHX_ U8 *a, U8 *b)
        while (a < b) {
            U8 c = UTF8SKIP(a);
 
-           if (b - a < c)
-               Perl_croak(aTHX_ "panic: utf8_distance: unaligned end");
+           if (b - a < c) {
+               if (ckWARN_d(WARN_UTF8)) {
+                   if (PL_op)
+                       Perl_warner(aTHX_ packWARN(WARN_UTF8),
+                                   "%s in %s", unees, OP_DESC(PL_op));
+                   else
+                       Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
+               }
+               return off;
+           }
            a += c;
            off--;
        }
@@ -592,8 +609,16 @@ Perl_utf8_distance(pTHX_ U8 *a, U8 *b)
        while (b < a) {
            U8 c = UTF8SKIP(b);
 
-           if (a - b < c)
-               Perl_croak(aTHX_ "panic: utf8_distance: unaligned end");
+           if (a - b < c) {
+               if (ckWARN_d(WARN_UTF8)) {
+                   if (PL_op)
+                       Perl_warner(aTHX_ packWARN(WARN_UTF8),
+                                   "%s in %s", unees, OP_DESC(PL_op));
+                   else
+                       Perl_warner(aTHX_ packWARN(WARN_UTF8), unees);
+               }
+               return off;
+           }
            b += c;
            off++;
        }
@@ -1509,8 +1534,12 @@ Perl_swash_init(pTHX_ char* pkg, char* name, SV *listsv, I32 minbits, I32 none)
        Copy(pv, PL_tokenbuf, len+1, char);
        PL_curcop->op_private = PL_hints;
     }
-    if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV)
+    if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
+        if (SvPOK(retval))
+           Perl_croak(aTHX_ "Can't find Unicode property definition \"%s\"",
+                      SvPV_nolen(retval));
        Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
+    }
     return retval;
 }
 
@@ -1588,7 +1617,9 @@ Perl_swash_fetch(pTHX_ SV *sv, U8 *ptr, bool do_utf8)
            /* We use utf8n_to_uvuni() as we want an index into
               Unicode tables, not a native character number.
             */
-           UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXLEN, NULL, 0);
+           UV code_point = utf8n_to_uvuni(ptr, UTF8_MAXLEN, 0,
+                                          ckWARN(WARN_UTF8) ?
+                                          0 : UTF8_ALLOW_ANY);
            SV *errsv_save;
            ENTER;
            SAVETMPS;