EBCDIC: the non-printable characters are different.

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

diff --git a/utf8.c b/utf8.c
index 2b5ae42..2afcbeb 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -1,6 +1,6 @@
 /*    utf8.c
  *
- *    Copyright (c) 1998-2001, Larry Wall
+ *    Copyright (c) 1998-2002, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -24,9 +24,9 @@
 #define PERL_IN_UTF8_C
 #include "perl.h"
 
-/* Unicode support */
+/* 
+=head1 Unicode Support
 
-/*
 =for apidoc A|U8 *|uvuni_to_utf8_flags|U8 *d|UV uv|UV flags
 
 Adds the UTF8 representation of the Unicode codepoint C<uv> to the end
@@ -54,7 +54,7 @@ is the recommended Unicode-aware way of saying
 U8 *
 Perl_uvuni_to_utf8_flags(pTHX_ U8 *d, UV uv, UV flags)
 {
-    if (ckWARN_d(WARN_UTF8)) {
+    if (ckWARN(WARN_UTF8)) {
         if (UNICODE_IS_SURROGATE(uv) &&
             !(flags & UNICODE_ALLOW_SURROGATE))
              Perl_warner(aTHX_ WARN_UTF8, "UTF-16 surrogate 0x%04"UVxf, uv);
@@ -1285,16 +1285,14 @@ to the hash is by Perl_to_utf8_case().
  */
 
 UV
-Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp,char *normal, char *special)
+Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp, char *normal, char *special)
 {
     UV uv;
 
     if (!*swashp)
         *swashp = swash_init("utf8", normal, &PL_sv_undef, 4, 0);
     uv = swash_fetch(*swashp, p, TRUE);
-    if (uv)
-        uv = UNI_TO_NATIVE(uv);
-    else {
+    if (!uv) {
         HV *hv;
         SV *keysv;
         HE *he;
@@ -1307,6 +1305,7 @@ Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp,char *normal
              SV *val = HeVAL(he);
              char *s = SvPV(val, *lenp);
              U8 c = *(U8*)s;
+
              if (*lenp > 1 || UNI_IS_INVARIANT(c))
                   Copy(s, ustrp, *lenp, U8);
              else {
@@ -1315,8 +1314,24 @@ Perl_to_utf8_case(pTHX_ U8 *p, U8* ustrp, STRLEN *lenp, SV **swashp,char *normal
                   ustrp[1] = UTF8_EIGHT_BIT_LO(c);
                   *lenp = 2;
              }
+#ifdef EBCDIC
+             {
+                  U8 tmpbuf[UTF8_MAXLEN_FOLD+1];
+                  U8 *d = tmpbuf;
+                  U8 *t, *tend;
+                  STRLEN tlen;
+
+                  for (t = ustrp, tend = t + *lenp; t < tend; t += tlen) {
+                       UV c = utf8_to_uvchr(t, &tlen);
+                       d = uvchr_to_utf8(d, UNI_TO_NATIVE(c));
+                  }
+                  *lenp = d - tmpbuf; 
+                  Copy(tmpbuf, ustrp, *lenp, U8);
+             }
+#endif
              return utf8_to_uvchr(ustrp, 0);
         }
+        uv  = NATIVE_TO_UNI(uv);
     }
     if (lenp)
        *lenp = UNISKIP(uv);
@@ -1646,8 +1661,8 @@ Allows length and flags to be passed to low level routine.
 
 =cut
 */
-/* On ASCII machines this is normally a macro but we want a
-   real function in case XS code wants it
+/* On ASCII machines this is normally a macro but we want
+   a real function in case XS code wants it
 */
 #undef Perl_utf8n_to_uvchr
 UV
@@ -1663,7 +1678,14 @@ Perl_utf8n_to_uvchr(pTHX_ U8 *s, STRLEN curlen, STRLEN *retlen, U32 flags)
 Build to the scalar dsv a displayable version of the string spv,
 length len, the displayable version being at most pvlim bytes long
 (if longer, the rest is truncated and "..." will be appended).
-The flags argument is currently unused but available for future extensions.
+
+The flags argument can have UNI_DISPLAY_ISPRINT set to display
+isPRINT()able characters as themselves, UNI_DISPLAY_BACKSLASH
+to display the \\[nrfta\\] as the backslashed versions (like '\n')
+(UNI_DISPLAY_BACKSLASH is preferred over UNI_DISPLAY_ISPRINT for \\).
+UNI_DISPLAY_QQ (and its alias UNI_DISPLAY_REGEX) have both
+UNI_DISPLAY_BACKSLASH and UNI_DISPLAY_ISPRINT turned on.
+
 The pointer to the PV of the dsv is returned.
 
 =cut */
@@ -1676,12 +1698,39 @@ Perl_pv_uni_display(pTHX_ SV *dsv, U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
     sv_setpvn(dsv, "", 0);
     for (s = (char *)spv, e = s + len; s < e; s += UTF8SKIP(s)) {
         UV u;
+        bool ok = FALSE;
+
         if (pvlim && SvCUR(dsv) >= pvlim) {
              truncated++;
              break;
         }
         u = utf8_to_uvchr((U8*)s, 0);
-        Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
+        if (u < 256) {
+            if (!ok && (flags & UNI_DISPLAY_BACKSLASH)) {
+                switch (u & 0xFF) {
+                case '\n':
+                    Perl_sv_catpvf(aTHX_ dsv, "\\n"); ok = TRUE; break;
+                case '\r':
+                    Perl_sv_catpvf(aTHX_ dsv, "\\r"); ok = TRUE; break;
+                case '\t':
+                    Perl_sv_catpvf(aTHX_ dsv, "\\t"); ok = TRUE; break;
+                case '\f':
+                    Perl_sv_catpvf(aTHX_ dsv, "\\f"); ok = TRUE; break;
+                case '\a':
+                    Perl_sv_catpvf(aTHX_ dsv, "\\a"); ok = TRUE; break;
+                case '\\':
+                    Perl_sv_catpvf(aTHX_ dsv, "\\" ); ok = TRUE; break;
+                default: break;
+                }
+            }
+            /* isPRINT() is the locale-blind version. */
+            if (!ok && (flags & UNI_DISPLAY_ISPRINT) && isPRINT(u & 0xFF)) {
+                Perl_sv_catpvf(aTHX_ dsv, "%c", (char)(u & 0xFF));
+                ok = TRUE;
+            }
+        }
+        if (!ok)
+            Perl_sv_catpvf(aTHX_ dsv, "\\x{%"UVxf"}", u);
     }
     if (truncated)
         sv_catpvn(dsv, "...", 3);
@@ -1693,9 +1742,11 @@ Perl_pv_uni_display(pTHX_ SV *dsv, U8 *spv, STRLEN len, STRLEN pvlim, UV flags)
 =for apidoc A|char *|sv_uni_display|SV *dsv|SV *ssv|STRLEN pvlim|UV flags
 
 Build to the scalar dsv a displayable version of the scalar sv,
-he displayable version being at most pvlim bytes long
+the displayable version being at most pvlim bytes long
 (if longer, the rest is truncated and "..." will be appended).
-The flags argument is currently unused but available for future extensions.
+
+The flags argument is as in pv_uni_display().
+
 The pointer to the PV of the dsv is returned.
 
 =cut */
@@ -1757,6 +1808,9 @@ Perl_ibcmp_utf8(pTHX_ const char *s1, char **pe1, register UV l1, bool u1, const
      if ((e1 == 0 && f1 == 0) || (e2 == 0 && f2 == 0) || (f1 == 0 && f2 == 0))
          return 1; /* mismatch; possible infinite loop or false positive */
 
+     if (!u1 || !u2)
+         natbuf[1] = 0; /* Need to terminate the buffer. */
+
      while ((e1 == 0 || p1 < e1) &&
            (f1 == 0 || p1 < f1) &&
            (e2 == 0 || p2 < e2) &&