tr///, help wanted.

Message-ID: <slrn8ljoc0.fbd.simon@justanother.perlhacker.org>

p4raw-id: //depot/cfgperl@6254

diff --git a/doop.c b/doop.c
index fe2df46..a7634c4 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -22,12 +22,13 @@
 #endif
 
 STATIC I32
-S_do_trans_CC_simple(pTHX_ SV *sv)
+S_do_trans_simple(pTHX_ SV *sv) /* SPC - OK */
 {
     dTHR;
     U8 *s;
     U8 *send;
     I32 matches = 0;
+    I32 hasutf = SvUTF8(sv);
     STRLEN len;
     short *tbl;
     I32 ch;
@@ -40,11 +41,15 @@ S_do_trans_CC_simple(pTHX_ SV *sv)
     send = s + len;
 
     while (s < send) {
-       if ((ch = tbl[*s]) >= 0) {
-           matches++;
-           *s = ch;
-       }
+        if (hasutf && *s & 0x80)
+            s+=UTF8SKIP(s); /* Given that we're here because tbl is !UTF8...*/
+        else {
+           if ((ch = tbl[*s]) >= 0) {
+               matches++;
+               *s = ch;
+           }
        s++;
+        }
     }
     SvSETMAGIC(sv);
 
@@ -52,12 +57,13 @@ S_do_trans_CC_simple(pTHX_ SV *sv)
 }
 
 STATIC I32
-S_do_trans_CC_count(pTHX_ SV *sv)
+S_do_trans_count(pTHX_ SV *sv)/* SPC - OK */
 {
     dTHR;
     U8 *s;
     U8 *send;
     I32 matches = 0;
+    I32 hasutf = SvUTF8(sv);
     STRLEN len;
     short *tbl;
 
@@ -69,21 +75,26 @@ S_do_trans_CC_count(pTHX_ SV *sv)
     send = s + len;
 
     while (s < send) {
-       if (tbl[*s] >= 0)
-           matches++;
-       s++;
+        if (hasutf && *s & 0x80)
+            s+=UTF8SKIP(s);
+        else {
+            if (tbl[*s] >= 0)
+                matches++;
+            s++;
+        }
     }
 
     return matches;
 }
 
 STATIC I32
-S_do_trans_CC_complex(pTHX_ SV *sv)
+S_do_trans_complex(pTHX_ SV *sv)/* SPC - OK */
 {
     dTHR;
     U8 *s;
     U8 *send;
     U8 *d;
+    I32 hasutf = SvUTF8(sv);
     I32 matches = 0;
     STRLEN len;
     short *tbl;
@@ -101,29 +112,37 @@ S_do_trans_CC_complex(pTHX_ SV *sv)
        U8* p = send;
 
        while (s < send) {
-           if ((ch = tbl[*s]) >= 0) {
-               *d = ch;
-               matches++;
-               if (p == d - 1 && *p == *d)
-                   matches--;
-               else
-                   p = d++;
-           }
-           else if (ch == -1)          /* -1 is unmapped character */
-               *d++ = *s;              /* -2 is delete character */
-           s++;
+            if (hasutf && *s & 0x80)
+                s+=UTF8SKIP(s);
+            else {
+               if ((ch = tbl[*s]) >= 0) {
+                   *d = ch;
+                   matches++;
+                   if (p == d - 1 && *p == *d)
+                       matches--;
+                   else
+                       p = d++;
+               }
+               else if (ch == -1)              /* -1 is unmapped character */
+                   *d++ = *s;          /* -2 is delete character */
+               s++;
+            }
        }
     }
     else {
        while (s < send) {
-           if ((ch = tbl[*s]) >= 0) {
-               *d = ch;
-               matches++;
-               d++;
-           }
-           else if (ch == -1)          /* -1 is unmapped character */
-               *d++ = *s;              /* -2 is delete character */
-           s++;
+            if (hasutf && *s & 0x80)
+                s+=UTF8SKIP(s);
+            else {
+               if ((ch = tbl[*s]) >= 0) {
+                   *d = ch;
+                   matches++;
+                   d++;
+               }
+               else if (ch == -1)              /* -1 is unmapped character */
+                   *d++ = *s;          /* -2 is delete character */
+               s++;
+            }
        }
     }
     matches += send - d;       /* account for disappeared chars */
@@ -135,12 +154,14 @@ S_do_trans_CC_complex(pTHX_ SV *sv)
 }
 
 STATIC I32
-S_do_trans_UU_simple(pTHX_ SV *sv)
+S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */
 {
     dTHR;
     U8 *s;
     U8 *send;
     U8 *d;
+    U8 *start;
+    U8 *dstart;
     I32 matches = 0;
     STRLEN len;
 
@@ -151,43 +172,83 @@ S_do_trans_UU_simple(pTHX_ SV *sv)
     UV extra = none + 1;
     UV final;
     UV uv;
+    I32 isutf; 
+    I32 howmany;
 
+    isutf = SvUTF8(sv);
     s = (U8*)SvPV(sv, len);
     send = s + len;
+    start = s;
 
     svp = hv_fetch(hv, "FINAL", 5, FALSE);
     if (svp)
        final = SvUV(*svp);
 
-    d = s;
+    /* d needs to be bigger than s, in case e.g. upgrading is required */
+    Newz(0, d, len*2+1, U8);
+    dstart = d;
     while (s < send) {
        if ((uv = swash_fetch(rv, s)) < none) {
            s += UTF8SKIP(s);
            matches++;
+        if (uv & 0x80 && !isutf) {  
+            /* Sneaky-upgrade dstart...d */
+            U8* new;
+            STRLEN len;
+            len = dstart - d;
+            new = bytes_to_utf8(dstart, &len);
+            Copy(new,dstart,len,U8*);
+            d = dstart + len;
+            isutf++;
+        }
            d = uv_to_utf8(d, uv);
        }
        else if (uv == none) {
            int i;
-           for (i = UTF8SKIP(s); i; i--)
-               *d++ = *s++;
+        i = UTF8SKIP(s);
+        if (i > 1 && !isutf) {
+            U8* new;
+            STRLEN len;
+            len = dstart - d;
+            new = bytes_to_utf8(dstart, &len);
+            Copy(new,dstart,len,U8*);
+            d = dstart + len;
+            isutf++;
+        }
+           while(i--)
+            *d++ = *s++;
        }
        else if (uv == extra) {
-           s += UTF8SKIP(s);
+           int i;
+        i = UTF8SKIP(s);
+           s += i;
            matches++;
+        if (i > 1 && !isutf) {
+            U8* new;
+            STRLEN len;
+            len = dstart - d;
+            new = bytes_to_utf8(dstart, &len);
+            Copy(new,dstart,len,U8*);
+            d = dstart + len;
+            isutf++;
+        }
            d = uv_to_utf8(d, final);
        }
        else
            s += UTF8SKIP(s);
     }
     *d = '\0';
-    SvCUR_set(sv, d - (U8*)SvPVX(sv));
+    SvPV_set(sv, dstart);
+    SvCUR_set(sv, d - dstart);
     SvSETMAGIC(sv);
+    if (isutf)
+        SvUTF8_on(sv);
 
     return matches;
 }
 
 STATIC I32
-S_do_trans_UU_count(pTHX_ SV *sv)
+S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */
 {
     dTHR;
     U8 *s;
@@ -202,6 +263,8 @@ S_do_trans_UU_count(pTHX_ SV *sv)
     UV uv;
 
     s = (U8*)SvPV(sv, len);
+    if (!SvUTF8(sv))
+        s = bytes_to_utf8(s, &len);
     send = s + len;
 
     while (s < send) {
@@ -214,7 +277,7 @@ S_do_trans_UU_count(pTHX_ SV *sv)
 }
 
 STATIC I32
-S_do_trans_UU_complex(pTHX_ SV *sv)
+S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */
 {
     dTHR;
     U8 *s;
@@ -403,7 +466,10 @@ Perl_do_trans(pTHX_ SV *sv)
 {
     dTHR;
     STRLEN len;
+    I32 hasutf = (PL_op->op_private & 
+                    (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF));
 
+    PL_op->op_private &= ~hasutf;
     if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL))
        Perl_croak(aTHX_ PL_no_modify);
 
@@ -419,22 +485,22 @@ Perl_do_trans(pTHX_ SV *sv)
 
     switch (PL_op->op_private & 63) {
     case 0:
-    if (SvUTF8(sv)) 
-        return do_trans_UU_simple(sv);
+    if (hasutf)
+        return do_trans_simple_utf8(sv);
     else
-        return do_trans_CC_simple(sv);
+        return do_trans_simple(sv);
 
     case OPpTRANS_IDENTICAL:
-    if (SvUTF8(sv)) 
-        return do_trans_UU_count(sv);
+    if (hasutf)
+        return do_trans_count_utf8(sv);
     else
-        return do_trans_CC_count(sv);
+        return do_trans_count(sv);
 
     default:
-       if (SvUTF8(sv))
-           return do_trans_UU_complex(sv); /* could be UC or CU too */
+    if (hasutf)
+           return do_trans_complex_utf8(sv);
        else
-           return do_trans_CC_complex(sv);
+           return do_trans_complex(sv);
     }
 }
 

diff --git a/embed.h b/embed.h
index fa199fb..f419792 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -846,14 +846,12 @@
 #define avhv_index             S_avhv_index
 #endif
 #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
-#define do_trans_CC_simple     S_do_trans_CC_simple
-#define do_trans_CC_count      S_do_trans_CC_count
-#define do_trans_CC_complex    S_do_trans_CC_complex
-#define do_trans_UU_simple     S_do_trans_UU_simple
-#define do_trans_UU_count      S_do_trans_UU_count
-#define do_trans_UU_complex    S_do_trans_UU_complex
-#define do_trans_UC_trivial    S_do_trans_UC_trivial
-#define do_trans_CU_trivial    S_do_trans_CU_trivial
+#define do_trans_simple                S_do_trans_simple
+#define do_trans_count         S_do_trans_count
+#define do_trans_complex       S_do_trans_complex
+#define do_trans_simple_utf8   S_do_trans_simple_utf8
+#define do_trans_count_utf8    S_do_trans_count_utf8
+#define do_trans_complex_utf8  S_do_trans_complex_utf8
 #endif
 #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)
 #define gv_init_sv             S_gv_init_sv
@@ -1105,6 +1103,7 @@
 #define sublex_push            S_sublex_push
 #define sublex_start           S_sublex_start
 #define filter_gets            S_filter_gets
+#define find_in_my_stash       S_find_in_my_stash
 #define new_constant           S_new_constant
 #define ao                     S_ao
 #define depcom                 S_depcom
@@ -2289,14 +2288,12 @@
 #define avhv_index(a,b,c)      S_avhv_index(aTHX_ a,b,c)
 #endif
 #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
-#define do_trans_CC_simple(a)  S_do_trans_CC_simple(aTHX_ a)
-#define do_trans_CC_count(a)   S_do_trans_CC_count(aTHX_ a)
-#define do_trans_CC_complex(a) S_do_trans_CC_complex(aTHX_ a)
-#define do_trans_UU_simple(a)  S_do_trans_UU_simple(aTHX_ a)
-#define do_trans_UU_count(a)   S_do_trans_UU_count(aTHX_ a)
-#define do_trans_UU_complex(a) S_do_trans_UU_complex(aTHX_ a)
-#define do_trans_UC_trivial(a) S_do_trans_UC_trivial(aTHX_ a)
-#define do_trans_CU_trivial(a) S_do_trans_CU_trivial(aTHX_ a)
+#define do_trans_simple(a)     S_do_trans_simple(aTHX_ a)
+#define do_trans_count(a)      S_do_trans_count(aTHX_ a)
+#define do_trans_complex(a)    S_do_trans_complex(aTHX_ a)
+#define do_trans_simple_utf8(a)        S_do_trans_simple_utf8(aTHX_ a)
+#define do_trans_count_utf8(a) S_do_trans_count_utf8(aTHX_ a)
+#define do_trans_complex_utf8(a)       S_do_trans_complex_utf8(aTHX_ a)
 #endif
 #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)
 #define gv_init_sv(a,b)                S_gv_init_sv(aTHX_ a,b)
@@ -2547,6 +2544,7 @@
 #define sublex_push()          S_sublex_push(aTHX)
 #define sublex_start()         S_sublex_start(aTHX)
 #define filter_gets(a,b,c)     S_filter_gets(aTHX_ a,b,c)
+#define find_in_my_stash(a,b)  S_find_in_my_stash(aTHX_ a,b)
 #define new_constant(a,b,c,d,e,f)      S_new_constant(aTHX_ a,b,c,d,e,f)
 #define ao(a)                  S_ao(aTHX_ a)
 #define depcom()               S_depcom(aTHX)
@@ -4479,22 +4477,18 @@
 #define avhv_index             S_avhv_index
 #endif
 #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
-#define S_do_trans_CC_simple   CPerlObj::S_do_trans_CC_simple
-#define do_trans_CC_simple     S_do_trans_CC_simple
-#define S_do_trans_CC_count    CPerlObj::S_do_trans_CC_count
-#define do_trans_CC_count      S_do_trans_CC_count
-#define S_do_trans_CC_complex  CPerlObj::S_do_trans_CC_complex
-#define do_trans_CC_complex    S_do_trans_CC_complex
-#define S_do_trans_UU_simple   CPerlObj::S_do_trans_UU_simple
-#define do_trans_UU_simple     S_do_trans_UU_simple
-#define S_do_trans_UU_count    CPerlObj::S_do_trans_UU_count
-#define do_trans_UU_count      S_do_trans_UU_count
-#define S_do_trans_UU_complex  CPerlObj::S_do_trans_UU_complex
-#define do_trans_UU_complex    S_do_trans_UU_complex
-#define S_do_trans_UC_trivial  CPerlObj::S_do_trans_UC_trivial
-#define do_trans_UC_trivial    S_do_trans_UC_trivial
-#define S_do_trans_CU_trivial  CPerlObj::S_do_trans_CU_trivial
-#define do_trans_CU_trivial    S_do_trans_CU_trivial
+#define S_do_trans_simple      CPerlObj::S_do_trans_simple
+#define do_trans_simple                S_do_trans_simple
+#define S_do_trans_count       CPerlObj::S_do_trans_count
+#define do_trans_count         S_do_trans_count
+#define S_do_trans_complex     CPerlObj::S_do_trans_complex
+#define do_trans_complex       S_do_trans_complex
+#define S_do_trans_simple_utf8 CPerlObj::S_do_trans_simple_utf8
+#define do_trans_simple_utf8   S_do_trans_simple_utf8
+#define S_do_trans_count_utf8  CPerlObj::S_do_trans_count_utf8
+#define do_trans_count_utf8    S_do_trans_count_utf8
+#define S_do_trans_complex_utf8        CPerlObj::S_do_trans_complex_utf8
+#define do_trans_complex_utf8  S_do_trans_complex_utf8
 #endif
 #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)
 #define S_gv_init_sv           CPerlObj::S_gv_init_sv
@@ -4953,6 +4947,8 @@
 #define sublex_start           S_sublex_start
 #define S_filter_gets          CPerlObj::S_filter_gets
 #define filter_gets            S_filter_gets
+#define S_find_in_my_stash     CPerlObj::S_find_in_my_stash
+#define find_in_my_stash       S_find_in_my_stash
 #define S_new_constant         CPerlObj::S_new_constant
 #define new_constant           S_new_constant
 #define S_ao                   CPerlObj::S_ao

diff --git a/embed.pl b/embed.pl
index c4cb705..bf41a0a 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -2199,14 +2199,12 @@ s       |I32    |avhv_index     |AV* av|SV* sv|U32 hash
 #endif
 
 #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
-s      |I32    |do_trans_CC_simple     |SV *sv
-s      |I32    |do_trans_CC_count      |SV *sv
-s      |I32    |do_trans_CC_complex    |SV *sv
-s      |I32    |do_trans_UU_simple     |SV *sv
-s      |I32    |do_trans_UU_count      |SV *sv
-s      |I32    |do_trans_UU_complex    |SV *sv
-s      |I32    |do_trans_UC_trivial    |SV *sv
-s      |I32    |do_trans_CU_trivial    |SV *sv
+s      |I32    |do_trans_simple        |SV *sv
+s      |I32    |do_trans_count         |SV *sv
+s      |I32    |do_trans_complex       |SV *sv
+s      |I32    |do_trans_simple_utf8   |SV *sv
+s      |I32    |do_trans_count_utf8    |SV *sv
+s      |I32    |do_trans_complex_utf8  |SV *sv
 #endif
 
 #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)

diff --git a/proto.h b/proto.h
index d46179a..0d70332 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -959,14 +959,12 @@ STATIC I32        S_avhv_index(pTHX_ AV* av, SV* sv, U32 hash);
 #endif
 
 #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
-STATIC I32     S_do_trans_CC_simple(pTHX_ SV *sv);
-STATIC I32     S_do_trans_CC_count(pTHX_ SV *sv);
-STATIC I32     S_do_trans_CC_complex(pTHX_ SV *sv);
-STATIC I32     S_do_trans_UU_simple(pTHX_ SV *sv);
-STATIC I32     S_do_trans_UU_count(pTHX_ SV *sv);
-STATIC I32     S_do_trans_UU_complex(pTHX_ SV *sv);
-STATIC I32     S_do_trans_UC_trivial(pTHX_ SV *sv);
-STATIC I32     S_do_trans_CU_trivial(pTHX_ SV *sv);
+STATIC I32     S_do_trans_simple(pTHX_ SV *sv);
+STATIC I32     S_do_trans_count(pTHX_ SV *sv);
+STATIC I32     S_do_trans_complex(pTHX_ SV *sv);
+STATIC I32     S_do_trans_simple_utf8(pTHX_ SV *sv);
+STATIC I32     S_do_trans_count_utf8(pTHX_ SV *sv);
+STATIC I32     S_do_trans_complex_utf8(pTHX_ SV *sv);
 #endif
 
 #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)

diff --git a/t/op/tr.t b/t/op/tr.t
index e9a1b4c..100dcfe 100755 (executable)
--- a/t/op/tr.t
+++ b/t/op/tr.t
@@ -5,7 +5,7 @@ BEGIN {
     unshift @INC, "../lib";
 }
 
-print "1..8\n";
+print "1..15\n";
 
 $_ = "abcdefghijklmnopqrstuvwxyz";
 
@@ -61,3 +61,50 @@ print "ok 7\n";
 $x =~ tr/A/B/;
 print "not " if $x ne 256.66.258 or length $x != 3;
 print "ok 8\n";
+
+{
+use utf8;
+
+# 9 - changing UTF8 characters in a UTF8 string, same length.
+$l = chr(300); $r = chr(400);
+$x = 200.300.400;
+$x =~ tr/\x{12c}/\x{190}/;
+printf "not (%vd) ", $x if $x ne 200.400.400 or length $x != 3;
+print "ok 9\n";
+
+# 10 - changing UTF8 characters in UTF8 string, more bytes.
+$x = 200.300.400;
+$x =~ tr/\x{12c}/\x{be8}/;
+printf "not (%vd) ", $x if $x ne 200.3048.400 or length $x != 3;
+print "ok 10\n";
+
+# 11 - introducing UTF8 characters to non-UTF8 string.
+$x = 100.125.60;
+$x =~ tr/\x{64}/\x{190}/;
+printf "not (%vd) ", $x if $x ne 400.125.60 or length $x != 3;
+print "ok 11\n";
+
+# 12 - removing UTF8 characters from UTF8 string
+$x = 400.125.60;
+$x =~ tr/\x{190}/\x{64}/;
+printf "not (%vd) ", $x if $x ne 100.125.60 or length $x != 3;
+print "ok 12\n";
+
+# 13 - counting UTF8 chars in UTF8 string
+$x = 400.125.60.400;
+$y = $x =~ tr/\x{190}/\x{190}/;
+print "not " if $y != 2;
+print "ok 13\n";
+
+# 14 - counting non-UTF8 chars in UTF8 string
+$x = 60.400.125.60.400;
+$y = $x =~ tr/\x{3c}/\x{3c}/;
+print "not " if $y != 2;
+print "ok 14\n";
+
+# 15 - counting UTF8 chars in non-UTF8 string
+$x = 200.125.60;
+$y = $x =~ tr/\x{190}/\x{190}/;
+print "not " if $y != 0;
+print "ok 15\n";
+}