This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[MERGE] various tr/// fixups, esp for /c and /d
authorDavid Mitchell <davem@iabyn.com>
Fri, 19 Jan 2018 14:08:28 +0000 (14:08 +0000)
committerDavid Mitchell <davem@iabyn.com>
Fri, 19 Jan 2018 14:08:28 +0000 (14:08 +0000)
This branch does the following:

Fixes an issue with tr/non_utf8/long_non_utf8/c, where
length(long_non_utf8) > 0x7fff.

Fixes an issue with tr/non_utf8/non_utf8/cd: basically, the
implicit \x{100}-\x{7fffffff} added to the searchlist by /c wasn't being
added.

Adds a lot of code comments to the various tr/// functions.

Adds tr///c tests - basically /c was almost completely untested.

Changes the layout of the op_pv transliteration table: it used to be roughly

      256 x short  - basic table
        1 x short  - length of extended table (n)
        n x short  - extended table

where the 2 and 3rd items were only present under /c. Its now

        1 x Size_t - length of table (256+n)
  (256+n) x short  - table - both basic and extended

where n == 0 apart from under /c.

The new table format also allowed the tr/non_utf8/non_utf8/ code branches
to be considerably simplified.

op_dump() now dumps the contents of the (non-utf8 variant) transliteration
table.

Removes I32's from the tr/non_utf8/non_utf8/ code paths, making it fully
64-bit clean.

Improves the pod for tr///.

13 files changed:
doop.c
dump.c
embed.fnc
ext/B/B.xs
lib/B/Deparse.pm
lib/B/Deparse.t
op.c
op.h
pod/perlop.pod
pp.c
proto.h
regen/op_private
t/op/tr.t

diff --git a/doop.c b/doop.c
index 2294281..0e2a8da 100644 (file)
--- a/doop.c
+++ b/doop.c
 #include <signal.h>
 #endif
 
-STATIC I32
+
+/* Helper function for do_trans().
+ * Handles non-utf8 cases(*) not involving the /c, /d, /s flags,
+ * and where search and replacement charlists aren't identical.
+ * (*) i.e. where the search and replacement charlists are non-utf8. sv may
+ * or may not be utf8.
+ */
+
+STATIC Size_t
 S_do_trans_simple(pTHX_ SV * const sv)
 {
-    I32 matches = 0;
+    Size_t matches = 0;
     STRLEN len;
     U8 *s = (U8*)SvPV_nomg(sv,len);
     U8 * const send = s+len;
-    const short * const tbl = (short*)cPVOP->op_pv;
+    const OPtrans_map * const tbl = (OPtrans_map*)cPVOP->op_pv;
 
     PERL_ARGS_ASSERT_DO_TRANS_SIMPLE;
 
@@ -44,7 +52,7 @@ S_do_trans_simple(pTHX_ SV * const sv)
     /* First, take care of non-UTF-8 input strings, because they're easy */
     if (!SvUTF8(sv)) {
        while (s < send) {
-           const I32 ch = tbl[*s];
+           const short ch = tbl->map[*s];
            if (ch >= 0) {
                matches++;
                *s = (U8)ch;
@@ -54,7 +62,7 @@ S_do_trans_simple(pTHX_ SV * const sv)
        SvSETMAGIC(sv);
     }
     else {
-       const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
+       const bool grows = cBOOL(PL_op->op_private & OPpTRANS_GROWS);
        U8 *d;
        U8 *dstart;
 
@@ -66,13 +74,13 @@ S_do_trans_simple(pTHX_ SV * const sv)
        dstart = d;
        while (s < send) {
            STRLEN ulen;
-           I32 ch;
+           short ch;
 
            /* Need to check this, otherwise 128..255 won't match */
            const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT);
-           if (c < 0x100 && (ch = tbl[c]) >= 0) {
+           if (c < 0x100 && (ch = tbl->map[c]) >= 0) {
                matches++;
-               d = uvchr_to_utf8(d, ch);
+               d = uvchr_to_utf8(d, (UV)ch);
                s += ulen;
            }
            else { /* No match -> copy */
@@ -95,14 +103,25 @@ S_do_trans_simple(pTHX_ SV * const sv)
     return matches;
 }
 
-STATIC I32
+
+/* Helper function for do_trans().
+ * Handles non-utf8 cases(*) where search and replacement charlists are
+ * identical: so the string isn't modified, and only a count of modifiable
+ * chars is needed.
+ * Note that it doesn't handle /d or /s, since these modify the string
+ * even if the replacement list is empty.
+ * (*) i.e. where the search and replacement charlists are non-utf8. sv may
+ * or may not be utf8.
+ */
+
+STATIC Size_t
 S_do_trans_count(pTHX_ SV * const sv)
 {
     STRLEN len;
     const U8 *s = (const U8*)SvPV_nomg_const(sv, len);
     const U8 * const send = s + len;
-    I32 matches = 0;
-    const short * const tbl = (short*)cPVOP->op_pv;
+    Size_t matches = 0;
+    const OPtrans_map * const tbl = (OPtrans_map*)cPVOP->op_pv;
 
     PERL_ARGS_ASSERT_DO_TRANS_COUNT;
 
@@ -111,17 +130,17 @@ S_do_trans_count(pTHX_ SV * const sv)
 
     if (!SvUTF8(sv)) {
        while (s < send) {
-            if (tbl[*s++] >= 0)
+            if (tbl->map[*s++] >= 0)
                 matches++;
        }
     }
     else {
-       const I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
+       const bool complement = cBOOL(PL_op->op_private & OPpTRANS_COMPLEMENT);
        while (s < send) {
            STRLEN ulen;
            const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT);
            if (c < 0x100) {
-               if (tbl[c] >= 0)
+               if (tbl->map[c] >= 0)
                    matches++;
            } else if (complement)
                matches++;
@@ -132,14 +151,22 @@ S_do_trans_count(pTHX_ SV * const sv)
     return matches;
 }
 
-STATIC I32
+
+/* Helper function for do_trans().
+ * Handles non-utf8 cases(*) involving the /c, /d, /s flags,
+ * and where search and replacement charlists aren't identical.
+ * (*) i.e. where the search and replacement charlists are non-utf8. sv may
+ * or may not be utf8.
+ */
+
+STATIC Size_t
 S_do_trans_complex(pTHX_ SV * const sv)
 {
     STRLEN len;
     U8 *s = (U8*)SvPV_nomg(sv, len);
     U8 * const send = s+len;
-    I32 matches = 0;
-    const short * const tbl = (short*)cPVOP->op_pv;
+    Size_t matches = 0;
+    const OPtrans_map * const tbl = (OPtrans_map*)cPVOP->op_pv;
 
     PERL_ARGS_ASSERT_DO_TRANS_COMPLEX;
 
@@ -153,7 +180,7 @@ S_do_trans_complex(pTHX_ SV * const sv)
        if (PL_op->op_private & OPpTRANS_SQUASH) {
            const U8* p = send;
            while (s < send) {
-               const I32 ch = tbl[*s];
+               const short ch = tbl->map[*s];
                if (ch >= 0) {
                    *d = (U8)ch;
                    matches++;
@@ -169,7 +196,7 @@ S_do_trans_complex(pTHX_ SV * const sv)
        }
        else {
            while (s < send) {
-               const I32 ch = tbl[*s];
+               const short ch = tbl->map[*s];
                if (ch >= 0) {
                    matches++;
                    *d++ = (U8)ch;
@@ -185,102 +212,55 @@ S_do_trans_complex(pTHX_ SV * const sv)
        SvCUR_set(sv, d - dstart);
     }
     else { /* is utf8 */
-       const I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
-       const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
-       const I32 del = PL_op->op_private & OPpTRANS_DELETE;
+       const bool squash = cBOOL(PL_op->op_private & OPpTRANS_SQUASH);
+       const bool grows  = cBOOL(PL_op->op_private & OPpTRANS_GROWS);
        U8 *d;
        U8 *dstart;
-       STRLEN rlen = 0;
+       Size_t size = tbl->size;
+        UV pch = 0xfeedface;
 
        if (grows)
            Newx(d, len*2+1, U8);
        else
            d = s;
        dstart = d;
-       if (complement && !del)
-           rlen = tbl[0x100];
 
-       if (PL_op->op_private & OPpTRANS_SQUASH) {
-           UV pch = 0xfeedface;
            while (s < send) {
                STRLEN len;
                const UV comp = utf8n_to_uvchr(s, send - s, &len,
                                               UTF8_ALLOW_DEFAULT);
-               I32 ch;
+               UV     ch;
+                short sch;
 
-               if (comp > 0xff) {
-                   if (!complement) {
-                       Move(s, d, len, U8);
-                       d += len;
-                   }
-                   else {
-                       matches++;
-                       if (!del) {
-                           ch = (rlen == 0) ? (I32)comp :
-                               (comp - 0x100 < rlen) ?
-                               tbl[comp+1] : tbl[0x100+rlen];
-                           if ((UV)ch != pch) {
-                               d = uvchr_to_utf8(d, ch);
-                               pch = (UV)ch;
-                           }
-                           s += len;
-                           continue;
-                       }
-                   }
-               }
-               else if ((ch = tbl[comp]) >= 0) {
+                sch = tbl->map[comp >= size ? size : comp];
+
+               if (sch >= 0) {
+                    ch = (UV)sch;
+                  replace:
                    matches++;
-                   if ((UV)ch != pch) {
+                   if (LIKELY(!squash || ch != pch)) {
                        d = uvchr_to_utf8(d, ch);
-                       pch = (UV)ch;
+                       pch = ch;
                    }
                    s += len;
                    continue;
                }
-               else if (ch == -1) {    /* -1 is unmapped character */
+               else if (sch == -1) {   /* -1 is unmapped character */
                    Move(s, d, len, U8);
                    d += len;
                }
-               else if (ch == -2)      /* -2 is delete character */
+               else if (sch == -2)     /* -2 is delete character */
                    matches++;
+                else {
+                    assert(sch == -3);  /* -3 is empty replacement */
+                    ch = comp;
+                    goto replace;
+                }
+
                s += len;
                pch = 0xfeedface;
            }
-       }
-       else {
-           while (s < send) {
-               STRLEN len;
-               const UV comp = utf8n_to_uvchr(s, send - s, &len,
-                                              UTF8_ALLOW_DEFAULT);
-               I32 ch;
-               if (comp > 0xff) {
-                   if (!complement) {
-                       Move(s, d, len, U8);
-                       d += len;
-                   }
-                   else {
-                       matches++;
-                       if (!del) {
-                           if (comp - 0x100 < rlen)
-                               d = uvchr_to_utf8(d, tbl[comp+1]);
-                           else
-                               d = uvchr_to_utf8(d, tbl[0x100+rlen]);
-                       }
-                   }
-               }
-               else if ((ch = tbl[comp]) >= 0) {
-                   d = uvchr_to_utf8(d, ch);
-                   matches++;
-               }
-               else if (ch == -1) {    /* -1 is unmapped character */
-                   Move(s, d, len, U8);
-                   d += len;
-               }
-               else if (ch == -2)      /* -2 is delete character */
-                   matches++;
-               s += len;
-           }
-       }
+
        if (grows) {
            sv_setpvn(sv, (char*)dstart, d - dstart);
            Safefree(dstart);
@@ -295,7 +275,15 @@ S_do_trans_complex(pTHX_ SV * const sv)
     return matches;
 }
 
-STATIC I32
+
+/* Helper function for do_trans().
+ * Handles utf8 cases(*) not involving the /c, /d, /s flags,
+ * and where search and replacement charlists aren't identical.
+ * (*) i.e. where the search or replacement charlists are utf8. sv may
+ * or may not be utf8.
+ */
+
+STATIC Size_t
 S_do_trans_simple_utf8(pTHX_ SV * const sv)
 {
     U8 *s;
@@ -303,8 +291,8 @@ S_do_trans_simple_utf8(pTHX_ SV * const sv)
     U8 *d;
     U8 *start;
     U8 *dstart, *dend;
-    I32 matches = 0;
-    const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
+    Size_t matches = 0;
+    const bool grows = cBOOL(PL_op->op_private & OPpTRANS_GROWS);
     STRLEN len;
     SV* const  rv =
 #ifdef USE_ITHREADS
@@ -393,13 +381,24 @@ S_do_trans_simple_utf8(pTHX_ SV * const sv)
     return matches;
 }
 
-STATIC I32
+
+/* Helper function for do_trans().
+ * Handles utf8 cases(*) where search and replacement charlists are
+ * identical: so the string isn't modified, and only a count of modifiable
+ * chars is needed.
+ * Note that it doesn't handle /d or /s, since these modify the string
+ * even if the replacement charlist is empty.
+ * (*) i.e. where the search or replacement charlists are utf8. sv may
+ * or may not be utf8.
+ */
+
+STATIC Size_t
 S_do_trans_count_utf8(pTHX_ SV * const sv)
 {
     const U8 *s;
     const U8 *start = NULL;
     const U8 *send;
-    I32 matches = 0;
+    Size_t matches = 0;
     STRLEN len;
     SV* const  rv =
 #ifdef USE_ITHREADS
@@ -436,15 +435,23 @@ S_do_trans_count_utf8(pTHX_ SV * const sv)
     return matches;
 }
 
-STATIC I32
+
+/* Helper function for do_trans().
+ * Handles utf8 cases(*) involving the /c, /d, /s flags,
+ * and where search and replacement charlists aren't identical.
+ * (*) i.e. where the search or replacement charlists are utf8. sv may
+ * or may not be utf8.
+ */
+
+STATIC Size_t
 S_do_trans_complex_utf8(pTHX_ SV * const sv)
 {
     U8 *start, *send;
     U8 *d;
-    I32 matches = 0;
-    const I32 squash   = PL_op->op_private & OPpTRANS_SQUASH;
-    const I32 del      = PL_op->op_private & OPpTRANS_DELETE;
-    const I32 grows    = PL_op->op_private & OPpTRANS_GROWS;
+    Size_t matches = 0;
+    const bool squash   = cBOOL(PL_op->op_private & OPpTRANS_SQUASH);
+    const bool del      = cBOOL(PL_op->op_private & OPpTRANS_DELETE);
+    const bool grows    = cBOOL(PL_op->op_private & OPpTRANS_GROWS);
     SV* const  rv =
 #ifdef USE_ITHREADS
                    PAD_SVl(cPADOP->op_padix);
@@ -597,12 +604,19 @@ S_do_trans_complex_utf8(pTHX_ SV * const sv)
     return matches;
 }
 
-I32
+
+/* Execute a tr//. sv is the value to be translated, while PL_op
+ * should be an OP_TRANS or OP_TRANSR op, whose op_pv field contains a
+ * translation table or whose op_sv field contains a swash.
+ * Returns a count of number of characters translated
+ */
+
+Size_t
 Perl_do_trans(pTHX_ SV *sv)
 {
     STRLEN len;
-    const I32 flags = PL_op->op_private;
-    const I32 hasutf = flags & (OPpTRANS_FROM_UTF | OPpTRANS_TO_UTF);
+    const U8 flags = PL_op->op_private;
+    const U8 hasutf = flags & (OPpTRANS_FROM_UTF | OPpTRANS_TO_UTF);
 
     PERL_ARGS_ASSERT_DO_TRANS;
 
@@ -618,8 +632,6 @@ Perl_do_trans(pTHX_ SV *sv)
        (void)SvPOK_only_UTF8(sv);
     }
 
-    DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
-
     /* If we use only OPpTRANS_IDENTICAL to bypass the READONLY check,
      * we must also rely on it to choose the readonly strategy.
      */
diff --git a/dump.c b/dump.c
index b2f0fc5..bdf2853 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -1263,10 +1263,42 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
 
     case OP_TRANS:
     case OP_TRANSR:
+        if (o->op_private & (OPpTRANS_FROM_UTF | OPpTRANS_TO_UTF)) {
+            /* utf8: table stored as a swash */
+#ifndef USE_ITHREADS
+       /* with ITHREADS, swash is stored in the pad, and the right pad
+        * may not be active here, so skip */
             S_opdump_indent(aTHX_ o, level, bar, file,
-                            "PV = 0x%" UVxf "\n",
-                            PTR2UV(cPVOPo->op_pv));
-            break;
+                            "SWASH = 0x%" UVxf "\n",
+                            PTR2UV(MUTABLE_SV(cSVOPo->op_sv)));
+#endif
+        }
+        else {
+            const OPtrans_map * const tbl = (OPtrans_map*)cPVOPo->op_pv;
+            SSize_t i, size = tbl->size;
+
+            S_opdump_indent(aTHX_ o, level, bar, file,
+                            "TABLE = 0x%" UVxf "\n",
+                            PTR2UV(tbl));
+            S_opdump_indent(aTHX_ o, level, bar, file,
+                "  SIZE: 0x%" UVxf "\n", (UV)size);
+
+            /* dump size+1 values, to include the extra slot at the end */
+            for (i = 0; i <= size; i++) {
+                short val = tbl->map[i];
+                if ((i & 0xf) == 0)
+                    S_opdump_indent(aTHX_ o, level, bar, file,
+                        " %4" UVxf ":", (UV)i);
+                if (val < 0)
+                    PerlIO_printf(file, " %2"  IVdf, (IV)val);
+                else
+                    PerlIO_printf(file, " %02" UVxf, (UV)val);
+
+                if ( i == size || (i & 0xf) == 0xf)
+                    PerlIO_printf(file, "\n");
+            }
+        }
+        break;
 
 
     default:
index cd654dd..b9351be 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -521,7 +521,7 @@ p   |Off_t  |do_sysseek     |NN GV* gv|Off_t pos|int whence
 : Defined in doio.c, used only in pp_sys.c
 pR     |Off_t  |do_tell        |NN GV* gv
 : Defined in doop.c, used only in pp.c
-p      |I32    |do_trans       |NN SV* sv
+p      |Size_t |do_trans       |NN SV* sv
 : Used in my.c and pp.c
 p      |UV     |do_vecget      |NN SV* sv|STRLEN offset|int size
 : Defined in doop.c, used only in mg.c (with /* XXX slurp this routine */)
@@ -2091,12 +2091,12 @@ Adp     |int    |nothreadhook
 p      |void   |init_constants
 
 #if defined(PERL_IN_DOOP_C)
-sR     |I32    |do_trans_simple        |NN SV * const sv
-sR     |I32    |do_trans_count         |NN SV * const sv
-sR     |I32    |do_trans_complex       |NN SV * const sv
-sR     |I32    |do_trans_simple_utf8   |NN SV * const sv
-sR     |I32    |do_trans_count_utf8    |NN SV * const sv
-sR     |I32    |do_trans_complex_utf8  |NN SV * const sv
+sR     |Size_t |do_trans_simple        |NN SV * const sv
+sR     |Size_t |do_trans_count         |NN SV * const sv
+sR     |Size_t |do_trans_complex       |NN SV * const sv
+sR     |Size_t |do_trans_simple_utf8   |NN SV * const sv
+sR     |Size_t |do_trans_count_utf8    |NN SV * const sv
+sR     |Size_t |do_trans_complex_utf8  |NN SV * const sv
 #endif
 
 #if defined(PERL_IN_GV_C)
index 6211225..d9d7715 100644 (file)
@@ -1022,20 +1022,18 @@ next(o)
                ret = make_sv_object(aTHX_ NULL);
                break;
            case 41: /* B::PVOP::pv */
-               /* OP_TRANS uses op_pv to point to a table of 256 or >=258
-                * shorts whereas other PVOPs point to a null terminated
-                * string.  */
-               if (    (cPVOPo->op_type == OP_TRANS
-                       || cPVOPo->op_type == OP_TRANSR) &&
-                       (cPVOPo->op_private & OPpTRANS_COMPLEMENT) &&
-                       !(cPVOPo->op_private & OPpTRANS_DELETE))
-               {
-                   const short* const tbl = (short*)cPVOPo->op_pv;
-                   const short entries = 257 + tbl[256];
-                   ret = newSVpvn_flags(cPVOPo->op_pv, entries * sizeof(short), SVs_TEMP);
-               }
-               else if (cPVOPo->op_type == OP_TRANS || cPVOPo->op_type == OP_TRANSR) {
-                   ret = newSVpvn_flags(cPVOPo->op_pv, 256 * sizeof(short), SVs_TEMP);
+                /* OP_TRANS uses op_pv to point to a OPtrans_map struct,
+                 * whereas other PVOPs point to a null terminated string.
+                 * For trans, for now just return the whole struct as a
+                 * string and let the caller unpack() it */
+               if (   cPVOPo->op_type == OP_TRANS
+                    || cPVOPo->op_type == OP_TRANSR)
+                {
+                    const OPtrans_map *const tbl = (OPtrans_map*)cPVOPo->op_pv;
+                   ret = newSVpvn_flags(cPVOPo->op_pv,
+                                              (char*)(&tbl->map[tbl->size + 1])
+                                            - (char*)tbl,
+                                            SVs_TEMP);
                }
                else
                    ret = newSVpvn_flags(cPVOPo->op_pv, strlen(cPVOPo->op_pv), SVs_TEMP);
index 86f262a..ab691c2 100644 (file)
@@ -58,6 +58,8 @@ our $AUTOLOAD;
 use warnings ();
 require feature;
 
+use Config;
+
 BEGIN {
     # List version-specific constants here.
     # Easiest way to keep this code portable between version looks to
@@ -5607,8 +5609,11 @@ sub collapse {
 
 sub tr_decode_byte {
     my($table, $flags) = @_;
-    my(@table) = unpack("s*", $table);
-    splice @table, 0x100, 1;   # Number of subsequent elements
+    my $ssize_t = $Config{ptrsize} == 8 ? 'q' : 'l';
+    my ($size, @table) = unpack("${ssize_t}s*", $table);
+    printf "XXX len=%d size=%d scalar\@table=%d\n", length($table), $size, scalar@table;
+    pop @table; # remove the wildcard final entry
+
     my($c, $tr, @from, @to, @delfrom, $delhyphen);
     if ($table[ord "-"] != -1 and
        $table[ord("-") - 1] == -1 || $table[ord("-") + 1] == -1)
index 00fbb01..cbee542 100644 (file)
@@ -1444,6 +1444,20 @@ tr/X//d;
 tr/X//s;
 tr/X//r;
 ####
+# tr with extended table (/c)
+tr/\000-\375/AB/c;
+tr/\000-\375/A-C/c;
+tr/\000-\375/A-D/c;
+tr/\000-\375/A-Z/c;
+tr/\000-\375/AB/cd;
+tr/\000-\375/A-C/cd;
+tr/\000-\375/A-D/cd;
+tr/\000-\375/A-Z/cd;
+tr/\000-\375/AB/cds;
+tr/\000-\375/A-C/cds;
+tr/\000-\375/A-D/cds;
+tr/\000-\375/A-Z/cds;
+####
 # [perl #119807] s//\(3)/ge should not warn when deparsed (\3 warns)
 s/foo/\(3);/eg;
 ####
diff --git a/op.c b/op.c
index ace79ad..2b87f9c 100644 (file)
--- a/op.c
+++ b/op.c
@@ -6294,6 +6294,10 @@ Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
     return fold_constants(op_integerize(op_std_init((OP *)binop)));
 }
 
+/* Helper function for S_pmtrans(): comparison function to sort an array
+ * of codepoint range pairs. Sorts by start point, or if equal, by end
+ * point */
+
 static int uvcompare(const void *a, const void *b)
     __attribute__nonnull__(1)
     __attribute__nonnull__(2)
@@ -6311,24 +6315,39 @@ static int uvcompare(const void *a, const void *b)
     return 0;
 }
 
+/* Given an OP_TRANS / OP_TRANSR op o, plus OP_CONST ops expr and repl
+ * containing the search and replacement strings, assemble into
+ * a translation table attached as o->op_pv.
+ * Free expr and repl.
+ * It expects the toker to have already set the
+ *   OPpTRANS_COMPLEMENT
+ *   OPpTRANS_SQUASH
+ *   OPpTRANS_DELETE
+ * flags as appropriate; this function may add
+ *   OPpTRANS_FROM_UTF
+ *   OPpTRANS_TO_UTF
+ *   OPpTRANS_IDENTICAL
+ *   OPpTRANS_GROWS
+ * flags
+ */
+
 static OP *
 S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
 {
     SV * const tstr = ((SVOP*)expr)->op_sv;
-    SV * const rstr =
-                             ((SVOP*)repl)->op_sv;
+    SV * const rstr = ((SVOP*)repl)->op_sv;
     STRLEN tlen;
     STRLEN rlen;
     const U8 *t = (U8*)SvPV_const(tstr, tlen);
     const U8 *r = (U8*)SvPV_const(rstr, rlen);
-    I32 i;
-    I32 j;
-    I32 grows = 0;
-    short *tbl;
-
-    const I32 complement = o->op_private & OPpTRANS_COMPLEMENT;
-    const I32 squash     = o->op_private & OPpTRANS_SQUASH;
-    I32 del              = o->op_private & OPpTRANS_DELETE;
+    Size_t i, j;
+    bool grows = FALSE;
+    OPtrans_map *tbl;
+    SSize_t struct_size; /* malloced size of table struct */
+
+    const bool complement = cBOOL(o->op_private & OPpTRANS_COMPLEMENT);
+    const bool squash     = cBOOL(o->op_private & OPpTRANS_SQUASH);
+    const bool del        = cBOOL(o->op_private & OPpTRANS_DELETE);
     SV* swash;
 
     PERL_ARGS_ASSERT_PMTRANS;
@@ -6342,6 +6361,14 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
         o->op_private |= OPpTRANS_TO_UTF;
 
     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
+
+        /* for utf8 translations, op_sv will be set to point to a swash
+         * containing codepoint ranges. This is done by first assembling
+         * a textual representation of the ranges in listsv then compiling
+         * it using swash_init(). For more details of the textual format,
+         * see L<perlunicode.pod/"User-Defined Character Properties"> .
+         */
+
        SV* const listsv = newSVpvs("# comment\n");
        SV* transv = NULL;
        const U8* tend = t + tlen;
@@ -6383,15 +6410,24 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
  * odd.  */
 
        if (complement) {
+            /* utf8 and /c:
+             * replace t/tlen/tend with a version that has the ranges
+             * complemented
+             */
            U8 tmpbuf[UTF8_MAXBYTES+1];
            UV *cp;
            UV nextmin = 0;
            Newx(cp, 2*tlen, UV);
            i = 0;
            transv = newSVpvs("");
+
+            /* convert search string into array of (start,end) range
+             * codepoint pairs stored in cp[]. Most "ranges" will start
+             * and end at the same char */
            while (t < tend) {
                cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
                t += ulen;
+                /* the toker converts X-Y into (X, ILLEGAL_UTF8_BYTE, Y) */
                if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
                    t++;
                    cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
@@ -6402,7 +6438,19 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
                }
                i++;
            }
+
+            /* sort the ranges */
            qsort(cp, i, 2*sizeof(UV), uvcompare);
+
+            /* Create a utf8 string containing the complement of the
+             * codepoint ranges. For example if cp[] contains [A,B], [C,D],
+             * then transv will contain the equivalent of:
+             * join '', map chr, 0,     ILLEGAL_UTF8_BYTE, A - 1,
+             *                   B + 1, ILLEGAL_UTF8_BYTE, C - 1,
+             *                   D + 1, ILLEGAL_UTF8_BYTE, 0x7fffffff;
+             * A range of a single char skips the ILLEGAL_UTF8_BYTE and
+             * end cp.
+             */
            for (j = 0; j < i; j++) {
                UV  val = cp[2*j];
                diff = val - nextmin;
@@ -6420,6 +6468,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
                if (val >= nextmin)
                    nextmin = val + 1;
            }
+
            t = uvchr_to_utf8(tmpbuf,nextmin);
            sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
            {
@@ -6436,6 +6485,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
        else if (!rlen && !del) {
            r = t; rlen = tlen; rend = tend;
        }
+
        if (!squash) {
                if ((!rlen && !del) || t == r ||
                    (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
@@ -6444,6 +6494,8 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
                }
        }
 
+        /* extract char ranges from t and r and append them to listsv */
+
        while (t < tend || tfirst <= tlast) {
            /* see if we need more "t" chars */
            if (tfirst > tlast) {
@@ -6516,9 +6568,11 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            tfirst += diff + 1;
        }
 
+        /* compile listsv into a swash and attach to o */
+
        none = ++max;
        if (del)
-           del = ++max;
+           ++max;
 
        if (max > 0xffff)
            bits = 32;
@@ -6557,50 +6611,88 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
        goto warnins;
     }
 
-    tbl = (short*)PerlMemShared_calloc(
-       (o->op_private & OPpTRANS_COMPLEMENT) &&
-           !(o->op_private & OPpTRANS_DELETE) ? 258 : 256,
-       sizeof(short));
+    /* Non-utf8 case: set o->op_pv to point to a simple 256+ entry lookup
+     * table. Entries with the value -1 indicate chars not to be
+     * translated, while -2 indicates a search char without a
+     * corresponding replacement char under /d.
+     *
+     * Normally, the table has 256 slots. However, in the presence of
+     * /c, the search charlist has an implicit \x{100}-\x{7fffffff}
+     * added, and if there are enough replacement chars to start pairing
+     * with the \x{100},... search chars, then a larger (> 256) table
+     * is allocated.
+     *
+     * In addition, regardless of whether under /c, an extra slot at the
+     * end is used to store the final repeating char, or -3 under an empty
+     * replacement list, or -2 under /d; which makes the runtime code
+     * easier.
+     *
+     * The toker will have already expanded char ranges in t and r.
+     */
+
+    /* Initially allocate 257-slot table: 256 for basic (non /c) usage,
+     * plus final slot for repeat/-2/-3. Later we realloc if excess > * 0.
+     * The OPtrans_map struct already contains one slot; hence the -1.
+     */
+    struct_size = sizeof(OPtrans_map) + (256 - 1 + 1)*sizeof(short);
+    tbl = (OPtrans_map*)PerlMemShared_calloc(struct_size, 1);
+    tbl->size = 256;
     cPVOPo->op_pv = (char*)tbl;
+
     if (complement) {
-       for (i = 0; i < (I32)tlen; i++)
-           tbl[t[i]] = -1;
+        Size_t excess;
+
+        /* in this branch, j is a count of 'consumed' (i.e. paired off
+         * with a search char) replacement chars (so j <= rlen always)
+         */
+       for (i = 0; i < tlen; i++)
+           tbl->map[t[i]] = -1;
+
        for (i = 0, j = 0; i < 256; i++) {
-           if (!tbl[i]) {
-               if (j >= (I32)rlen) {
+           if (!tbl->map[i]) {
+               if (j == rlen) {
                    if (del)
-                       tbl[i] = -2;
+                       tbl->map[i] = -2;
                    else if (rlen)
-                       tbl[i] = r[j-1];
+                       tbl->map[i] = r[j-1];
                    else
-                       tbl[i] = (short)i;
+                       tbl->map[i] = (short)i;
                }
                else {
-                   if (UVCHR_IS_INVARIANT(i) && ! UVCHR_IS_INVARIANT(r[j]))
-                       grows = 1;
-                   tbl[i] = r[j++];
+                   tbl->map[i] = r[j++];
                }
+                if (   tbl->map[i] >= 0
+                    &&  UVCHR_IS_INVARIANT((UV)i)
+                    && !UVCHR_IS_INVARIANT((UV)(tbl->map[i]))
+                )
+                    grows = TRUE;
            }
        }
-       if (!del) {
-           if (!rlen) {
-               j = rlen;
-               if (!squash)
-                   o->op_private |= OPpTRANS_IDENTICAL;
-           }
-           else if (j >= (I32)rlen)
-               j = rlen - 1;
-           else {
-               tbl = 
-                   (short *)
-                   PerlMemShared_realloc(tbl,
-                                         (0x101+rlen-j) * sizeof(short));
-               cPVOPo->op_pv = (char*)tbl;
-           }
-           tbl[0x100] = (short)(rlen - j);
-           for (i=0; i < (I32)rlen - j; i++)
-               tbl[0x101+i] = r[j+i];
-       }
+
+        ASSUME(j <= rlen);
+        excess = rlen - j;
+
+        if (excess) {
+            /* More replacement chars than search chars:
+             * store excess replacement chars at end of main table.
+             */
+
+            struct_size += excess;
+            tbl = (OPtrans_map*)PerlMemShared_realloc(tbl,
+                        struct_size + excess * sizeof(short));
+            tbl->size += excess;
+            cPVOPo->op_pv = (char*)tbl;
+
+            for (i = 0; i < excess; i++)
+                tbl->map[i + 256] = r[j+i];
+        }
+        else {
+            /* no more replacement chars than search chars */
+            if (!rlen && !del && !squash)
+                o->op_private |= OPpTRANS_IDENTICAL;
+        }
+
+        tbl->map[tbl->size] = del ? -2 : rlen ? r[rlen - 1] : -3;
     }
     else {
        if (!rlen && !del) {
@@ -6611,26 +6703,30 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
        else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
            o->op_private |= OPpTRANS_IDENTICAL;
        }
+
        for (i = 0; i < 256; i++)
-           tbl[i] = -1;
-       for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
-           if (j >= (I32)rlen) {
+           tbl->map[i] = -1;
+       for (i = 0, j = 0; i < tlen; i++,j++) {
+           if (j >= rlen) {
                if (del) {
-                   if (tbl[t[i]] == -1)
-                       tbl[t[i]] = -2;
+                   if (tbl->map[t[i]] == -1)
+                       tbl->map[t[i]] = -2;
                    continue;
                }
                --j;
            }
-           if (tbl[t[i]] == -1) {
+           if (tbl->map[t[i]] == -1) {
                 if (     UVCHR_IS_INVARIANT(t[i])
                     && ! UVCHR_IS_INVARIANT(r[j]))
-                   grows = 1;
-               tbl[t[i]] = r[j];
+                   grows = TRUE;
+               tbl->map[t[i]] = r[j];
            }
        }
+        tbl->map[tbl->size] = del ? -1 : rlen ? -1 : -3;
     }
 
+    /* both non-utf8 and utf8 code paths end up here */
+
   warnins:
     if(del && rlen == tlen) {
        Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator"); 
@@ -6646,6 +6742,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
     return o;
 }
 
+
 /*
 =for apidoc Am|OP *|newPMOP|I32 type|I32 flags
 
diff --git a/op.h b/op.h
index eb62c94..ed4ff9d 100644 (file)
--- a/op.h
+++ b/op.h
@@ -627,6 +627,15 @@ typedef enum {
 #define ref(o, type) doref(o, type, TRUE)
 #endif
 
+
+/* translation table attached to OP_TRANS/OP_TRANSR ops */
+
+typedef struct {
+    Size_t size; /* number of entries in map[], not including final slot */
+    short map[1]; /* Unwarranted chumminess */
+} OPtrans_map;
+
+
 /*
 =head1 Optree Manipulation Functions
 
index ceeb97f..4b8d7e2 100644 (file)
@@ -2489,22 +2489,36 @@ Options:
        untouched.
 
 If the C</c> modifier is specified, the I<SEARCHLIST> character set
-is complemented.  If the C</d> modifier is specified, any characters
+is complemented. So for example these two are equivalent (the exact
+maximum number will depend on your platform):
+
+    tr/\x00-\xfd/ABCD/c
+    tr/\xfe-\x{7fffffff}/ABCD/
+
+If the C</d> modifier is specified, any characters
 specified by I<SEARCHLIST> not found in I<REPLACEMENTLIST> are deleted.
 (Note that this is slightly more flexible than the behavior of some
 B<tr> programs, which delete anything they find in the I<SEARCHLIST>,
-period.)  If the C</s> modifier is specified, sequences of characters
-that were transliterated to the same character are squashed down
-to a single instance of the character.
+period.)
+
+If the C</s> modifier is specified, runs of the same character in the
+result, where each those characters were substituted by the
+transliteration, are squashed down to a single instance of the character.
 
 If the C</d> modifier is used, the I<REPLACEMENTLIST> is always interpreted
 exactly as specified.  Otherwise, if the I<REPLACEMENTLIST> is shorter
 than the I<SEARCHLIST>, the final character is replicated till it is long
 enough.  If the I<REPLACEMENTLIST> is empty, the I<SEARCHLIST> is replicated.
 This latter is useful for counting characters in a class or for
-squashing character sequences in a class.
+squashing character sequences in a class. For example, each of these pairs
+are equivalent:
 
-Examples:
+    tr/abcd//            tr/abcd/abcd/
+    tr/abcd/AB/          tr/abcd/ABBB/
+    tr/abcd//d           s/[abcd]//g
+    tr/abcd/AB/d         (tr/ab/AB/ + s/[cd]//g)  - but run together
+
+Some examples:
 
     $ARGV[1] =~ tr/A-Z/a-z/;   # canonicalize to lower case ASCII
 
diff --git a/pp.c b/pp.c
index 4b1ccbb..d50ad7d 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -689,8 +689,8 @@ PP(pp_trans)
        PUSHs(newsv);
     }
     else {
-       I32 i = do_trans(sv);
-       mPUSHi(i);
+       Size_t i = do_trans(sv);
+       mPUSHi((UV)i);
     }
     RETURN;
 }
diff --git a/proto.h b/proto.h
index 8e0c669..042a4ee 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -822,7 +822,7 @@ PERL_CALLCONV Off_t Perl_do_tell(pTHX_ GV* gv)
 #define PERL_ARGS_ASSERT_DO_TELL       \
        assert(gv)
 
-PERL_CALLCONV I32      Perl_do_trans(pTHX_ SV* sv);
+PERL_CALLCONV Size_t   Perl_do_trans(pTHX_ SV* sv);
 #define PERL_ARGS_ASSERT_DO_TRANS      \
        assert(sv)
 PERL_CALLCONV UV       Perl_do_vecget(pTHX_ SV* sv, STRLEN offset, int size);
@@ -4542,32 +4542,32 @@ STATIC IO *     S_openn_setup(pTHX_ GV *gv, char *mode, PerlIO **saveifp, PerlIO **s
        assert(gv); assert(mode); assert(saveifp); assert(saveofp); assert(savefd); assert(savetype)
 #endif
 #if defined(PERL_IN_DOOP_C)
-STATIC I32     S_do_trans_complex(pTHX_ SV * const sv)
+STATIC Size_t  S_do_trans_complex(pTHX_ SV * const sv)
                        __attribute__warn_unused_result__;
 #define PERL_ARGS_ASSERT_DO_TRANS_COMPLEX      \
        assert(sv)
 
-STATIC I32     S_do_trans_complex_utf8(pTHX_ SV * const sv)
+STATIC Size_t  S_do_trans_complex_utf8(pTHX_ SV * const sv)
                        __attribute__warn_unused_result__;
 #define PERL_ARGS_ASSERT_DO_TRANS_COMPLEX_UTF8 \
        assert(sv)
 
-STATIC I32     S_do_trans_count(pTHX_ SV * const sv)
+STATIC Size_t  S_do_trans_count(pTHX_ SV * const sv)
                        __attribute__warn_unused_result__;
 #define PERL_ARGS_ASSERT_DO_TRANS_COUNT        \
        assert(sv)
 
-STATIC I32     S_do_trans_count_utf8(pTHX_ SV * const sv)
+STATIC Size_t  S_do_trans_count_utf8(pTHX_ SV * const sv)
                        __attribute__warn_unused_result__;
 #define PERL_ARGS_ASSERT_DO_TRANS_COUNT_UTF8   \
        assert(sv)
 
-STATIC I32     S_do_trans_simple(pTHX_ SV * const sv)
+STATIC Size_t  S_do_trans_simple(pTHX_ SV * const sv)
                        __attribute__warn_unused_result__;
 #define PERL_ARGS_ASSERT_DO_TRANS_SIMPLE       \
        assert(sv)
 
-STATIC I32     S_do_trans_simple_utf8(pTHX_ SV * const sv)
+STATIC Size_t  S_do_trans_simple_utf8(pTHX_ SV * const sv)
                        __attribute__warn_unused_result__;
 #define PERL_ARGS_ASSERT_DO_TRANS_SIMPLE_UTF8  \
        assert(sv)
index eb53edf..49cb4bc 100644 (file)
@@ -513,14 +513,15 @@ addbits('sassign',
 
 for (qw(trans transr)) {
     addbits($_,
-        0 => qw(OPpTRANS_FROM_UTF   <UTF),
-        1 => qw(OPpTRANS_TO_UTF     >UTF),
+        0 => qw(OPpTRANS_FROM_UTF   <UTF),    # search chars are utf8
+        1 => qw(OPpTRANS_TO_UTF     >UTF),    # replacement chars are utf8
         2 => qw(OPpTRANS_IDENTICAL  IDENT),   # right side is same as left
-        3 => qw(OPpTRANS_SQUASH     SQUASH),
+        3 => qw(OPpTRANS_SQUASH     SQUASH),  # /s
         # 4 is used for OPpTARGET_MY
-        5 => qw(OPpTRANS_COMPLEMENT COMPL),
-        6 => qw(OPpTRANS_GROWS      GROWS),
-        7 => qw(OPpTRANS_DELETE     DEL),
+        5 => qw(OPpTRANS_COMPLEMENT COMPL),   # /c
+        6 => qw(OPpTRANS_GROWS      GROWS),   # replacement chars longer than
+                                              #    src chars
+        7 => qw(OPpTRANS_DELETE     DEL),     # /d
     );
 }
 
index 323a5c3..0f74936 100644 (file)
--- a/t/op/tr.t
+++ b/t/op/tr.t
@@ -13,7 +13,7 @@ BEGIN {
 
 use utf8;
 
-plan tests => 216;
+plan tests => 300;
 
 # Test this first before we extend the stack with other operations.
 # This caused an asan failure due to a bad write past the end of the stack.
@@ -45,6 +45,432 @@ like $@,
      qr/Invalid range "\\x\{0101\}-\\x\{0100\}" in transliteration operator/,
      "UTF-8 range with min > max";
 
+
+# Test /c and variants, with all the search and replace chars being
+# non-utf8, but with both non-utf8 and utf8 strings.
+
+{
+    my $all255            = join '', map chr, 0..0xff;
+    my $all255_twice      = join '', map chr, map { ($_, $_) } 0..0xff;
+    my $all255_plus       = join '', map chr, 0..0x11f;
+    my $all255_twice_plus = join '', map chr, map { ($_, $_) } 0..0x11f;
+    my ($c, $s);
+
+
+    # length(replacement) == 0
+    # non-utf8 string
+
+    $s = $all255;
+    $c = $s =~ tr/\x40-\xbf//c;
+    is $s, $all255, "/c   ==0";
+    is $c, 0x80, "/c   ==0  count";
+
+    $s = $all255;
+    $c = $s =~ tr/\x40-\xbf//cd;
+    is $s, join('', map chr, 0x40..0xbf), "/cd  ==0";
+    is $c, 0x80, "/cd  ==0  count";
+
+    $s = $all255_twice;
+    $c = $s =~ tr/\x40-\xbf//cs;
+    is $s, join('', map chr,
+                0x00..0x3f,
+                (map  { ($_, $_) } 0x40..0xbf),
+                0xc0..0xff,
+            ),
+        "/cs  ==0";
+    is $c, 0x100, "/cs  ==0  count";
+
+    $s = $all255_twice;
+    $c = $s =~ tr/\x40-\xbf//csd;
+    is $s, join('', map chr, (map  { ($_, $_) } 0x40..0xbf)), "/csd ==0";
+    is $c, 0x100, "/csd ==0  count";
+
+
+    # length(search) > length(replacement)
+    # non-utf8 string
+
+    $s = $all255;
+    $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x2f/c;
+    is $s, join('', map chr,
+                0x80..0xbf,
+                0x40..0xbf,
+                0x00..0x2f,
+                ((0x2f) x 16),
+            ),
+        "/c   >";
+    is $c, 0x80, "/c   >  count";
+
+    $s = $all255;
+    $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x2f/cd;
+    is $s, join('', map chr, 0x80..0xbf, 0x40..0xbf, 0x00..0x2f),
+        "/cd  >";
+    is $c, 0x80, "/cd  >  count";
+
+    $s = $all255_twice;
+    $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x2f/cs;
+    is $s, join('', map chr,
+                0x80..0xbf,
+                (map  { ($_, $_) } 0x40..0xbf),
+                0x00..0x2f,
+            ),
+        "/cs  >";
+    is $c, 0x100, "/cs  >  count";
+
+    $s = $all255_twice;
+    $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x2f/csd;
+    is $s, join('', map chr,
+                0x80..0xbf,
+                (map  { ($_, $_) } 0x40..0xbf),
+                0x00..0x2f,
+            ),
+        "/csd >";
+    is $c, 0x100, "/csd >  count";
+
+
+    # length(search) == length(replacement)
+    # non-utf8 string
+
+    $s = $all255;
+    $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x3f/c;
+    is $s, join('', map chr, 0x80..0xbf, 0x40..0xbf, 0x00..0x3f), "/c   ==";
+    is $c, 0x80, "/c   == count";
+
+    $s = $all255;
+    $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x3f/cd;
+    is $s, join('', map chr, 0x80..0xbf, 0x40..0xbf, 0x00..0x3f), "/cd  ==";
+    is $c, 0x80, "/cd  == count";
+
+    $s = $all255_twice;
+    $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x3f/cs;
+    is $s, join('', map chr,
+                0x80..0xbf,
+                (map  { ($_, $_) } 0x40..0xbf),
+                0x00..0x3f,
+            ),
+        "/cs  ==";
+    is $c, 0x100, "/cs  == count";
+
+    $s = $all255_twice;
+    $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x3f/csd;
+    is $s, join('', map chr,
+                0x80..0xbf,
+                (map  { ($_, $_) } 0x40..0xbf),
+                0x00..0x3f,
+            ),
+        "/csd ==";
+    is $c, 0x100, "/csd == count";
+
+    # length(search) == length(replacement) - 1
+    # non-utf8 string
+
+
+    $s = $all255;
+    $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x30/c;
+    is $s, join('', map chr, 0x80..0xbf, 0x40..0xbf, 0x00..0x2f, 0xf0..0xff),
+        "/c   =-";
+    is $c, 0x70, "/c   =-  count";
+
+    $s = $all255;
+    $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x30/cd;
+    is $s, join('', map chr, 0x80..0xbf, 0x40..0xbf, 0x00..0x2f, 0xf0..0xff),
+        "/cd  =-";
+    is $c, 0x70, "/cd  =-  count";
+
+    $s = $all255_twice;
+    $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x30/cs;
+    is $s, join('', map chr,
+                0x80..0xbf,
+                (map  { ($_, $_) } 0x40..0xbf),
+                0x00..0x2f,
+                (map  { ($_, $_) } 0xf0..0xff),
+            ),
+        "/cs  =-";
+    is $c, 0xe0, "/cs  =-  count";
+
+    $s = $all255_twice;
+    $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x30/csd;
+    is $s, join('', map chr,
+                0x80..0xbf,
+                (map  { ($_, $_) } 0x40..0xbf),
+                0x00..0x2f,
+                (map  { ($_, $_) } 0xf0..0xff),
+            ),
+        "/csd =-";
+    is $c, 0xe0, "/csd =-  count";
+
+    # length(search) < length(replacement)
+    # non-utf8 string
+
+    $s = $all255;
+    $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x3f/c;
+    is $s, join('', map chr, 0x80..0xbf, 0x40..0xbf, 0x00..0x2f, 0xf0..0xff),
+        "/c   <";
+    is $c, 0x70, "/c   <  count";
+
+    $s = $all255;
+    $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x3f/cd;
+    is $s, join('', map chr, 0x80..0xbf, 0x40..0xbf, 0x00..0x2f, 0xf0..0xff),
+        "/cd  <";
+    is $c, 0x70, "/cd  <  count";
+
+    $s = $all255_twice;
+    $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x3f/cs;
+    is $s, join('', map chr,
+                0x80..0xbf,
+                (map  { ($_, $_) } 0x40..0xbf),
+                0x00..0x2f,
+                (map  { ($_, $_) } 0xf0..0xff),
+            ),
+        "/cs  <";
+    is $c, 0xe0, "/cs  <  count";
+
+    $s = $all255_twice;
+    $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x3f/csd;
+    is $s, join('', map chr,
+                0x80..0xbf,
+                (map  { ($_, $_) } 0x40..0xbf),
+                0x00..0x2f,
+                (map  { ($_, $_) } 0xf0..0xff),
+            ),
+        "/csd <";
+    is $c, 0xe0, "/csd <  count";
+
+
+    # length(replacement) == 0
+    # with some >= 0x100 utf8 chars in the string to be modified
+
+    $s = $all255_plus;
+    $c = $s =~ tr/\x40-\xbf//c;
+    is $s, $all255_plus, "/c   ==0U";
+    is $c, 0xa0, "/c   ==0U  count";
+
+    $s = $all255_plus;
+    $c = $s =~ tr/\x40-\xbf//cd;
+    is $s, join('', map chr, 0x40..0xbf), "/cd  ==0U";
+    is $c, 0xa0, "/cd  ==0U  count";
+
+    $s = $all255_twice_plus;
+    $c = $s =~ tr/\x40-\xbf//cs;
+    is $s, join('', map chr,
+                0x00..0x3f,
+                (map  { ($_, $_) } 0x40..0xbf),
+                0xc0..0x11f,
+            ),
+        "/cs  ==0U";
+    is $c, 0x140, "/cs  ==0U  count";
+
+    $s = $all255_twice_plus;
+    $c = $s =~ tr/\x40-\xbf//csd;
+    is $s, join('', map chr, (map  { ($_, $_) } 0x40..0xbf)), "/csd ==0U";
+    is $c, 0x140, "/csd ==0U  count";
+
+    # length(search) > length(replacement)
+    # with some >= 0x100 utf8 chars in the string to be modified
+
+    $s = $all255_plus;
+    $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x2f/c;
+    is $s, join('', map chr,
+                0x80..0xbf,
+                0x40..0xbf,
+                0x00..0x2f,
+                ((0x2f) x 48),
+            ),
+        "/c   >U";
+    is $c, 0xa0, "/c   >U count";
+
+    $s = $all255_plus;
+    $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x2f/cd;
+    is $s, join('', map chr, 0x80..0xbf, 0x40..0xbf, 0x00..0x2f),
+        "/cd  >U";
+    is $c, 0xa0, "/cd  >U count";
+
+    $s = $all255_twice_plus . "\x3f\x3f\x{200}\x{300}";
+    $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x2f/cs;
+    is $s, join('', map chr,
+                0x80..0xbf,
+                (map  { ($_, $_) } 0x40..0xbf),
+                0x00..0x2f,
+                0xbf,
+                0x2f,
+            ),
+        "/cs  >U";
+    is $c, 0x144, "/cs  >U count";
+
+    $s = $all255_twice_plus;
+    $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x2f/csd;
+    is $s, join('', map chr,
+                0x80..0xbf,
+                (map  { ($_, $_) } 0x40..0xbf),
+                0x00..0x2f,
+            ),
+        "/csd >U";
+    is $c, 0x140, "/csd >U count";
+
+    # length(search) == length(replacement)
+    # with some >= 0x100 utf8 chars in the string to be modified
+
+    $s = $all255_plus;
+    $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x3f/c;
+    is $s, join('', map chr,
+                0x80..0xbf,
+                0x40..0xbf,
+                0x00..0x3f,
+                ((0x3f) x 32),
+            ),
+        "/c   ==U";
+    is $c, 0xa0, "/c   ==U count";
+
+    $s = $all255_plus;
+    $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x3f/cd;
+    is $s, join('', map chr, 0x80..0xbf, 0x40..0xbf, 0x00..0x3f), "/cd ==U";
+    is $c, 0xa0, "/cd  ==U count";
+
+    $s = $all255_twice_plus . "\x3f\x3f\x{200}\x{300}";
+    $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x3f/cs;
+    is $s, join('', map chr,
+                0x80..0xbf,
+                (map  { ($_, $_) } 0x40..0xbf),
+                0x00..0x3f,
+                0xbf,
+                0x3f,
+            ),
+        "/cs  ==U";
+    is $c, 0x144, "/cs  ==U count";
+
+    $s = $all255_twice_plus;
+    $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x3f/csd;
+    is $s, join('', map chr,
+                0x80..0xbf,
+                (map  { ($_, $_) } 0x40..0xbf),
+                0x00..0x3f,
+            ),
+        "/csd ==U";
+    is $c, 0x140, "/csd ==U count";
+
+
+    # length(search) == length(replacement) - 1
+    # with some >= 0x100 utf8 chars in the string to be modified
+
+    $s = $all255_plus;
+    $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x40/c;
+    is $s, join('', map chr,
+                0x80..0xbf,
+                0x40..0xbf,
+                0x00..0x40,
+                ((0x40) x 31),
+            ),
+        "/c   =-U";
+    is $c, 0xa0, "/c   =-U count";
+
+    $s = $all255_plus;
+    $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x40/cd;
+    is $s, join('', map chr, 0x80..0xbf, 0x40..0xbf, 0x00..0x40), "/cd =-U";
+    is $c, 0xa0, "/cd  =-U count";
+
+    $s = $all255_twice_plus . "\x3f\x3f\x{200}\x{300}";
+    $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x40/cs;
+    is $s, join('', map chr,
+                0x80..0xbf,
+                (map  { ($_, $_) } 0x40..0xbf),
+                0x00..0x40,
+                0xbf,
+                0x40,
+            ),
+        "/cs  =-U";
+    is $c, 0x144, "/cs  =-U count";
+
+    $s = $all255_twice_plus;
+    $c = $s =~ tr/\x40-\xbf/\x80-\xbf\x00-\x40/csd;
+    is $s, join('', map chr,
+                0x80..0xbf,
+                (map  { ($_, $_) } 0x40..0xbf),
+                0x00..0x40,
+            ),
+        "/csd =-U";
+    is $c, 0x140, "/csd =-U count";
+
+
+
+    # length(search) < length(replacement),
+    # with some >= 0x100 utf8 chars in the string to be modified
+
+    $s = $all255_plus;
+    $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x3f/c;
+    is $s, join('', map chr,
+                    0x80..0xbf,
+                    0x40..0xbf,
+                    0x00..0x2f,
+                    0xf0..0xff,
+                    0x30..0x3f,
+                    ((0x3f)x 16),
+                ),
+        "/c   <U";
+    is $c, 0x90, "/c   <U count";
+
+    $s = $all255_plus;
+    $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x3f/cd;
+    is $s, join('', map chr,
+                0x80..0xbf,
+                0x40..0xbf,
+                0x00..0x2f,
+                0xf0..0xff,
+                0x30..0x3f,
+                ),
+            "/cd  <U";
+    is $c, 0x90, "/cd  <U count";
+
+    $s = $all255_twice_plus . "\x3f\x3f\x{200}\x{300}";
+    $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x3f/cs;
+    is $s, join('', map chr,
+                0x80..0xbf,
+                (map  { ($_, $_) } 0x40..0xbf),
+                0x00..0x2f,
+                (map  { ($_, $_) } 0xf0..0xff),
+                0x30..0x3f,
+                0xbf,
+                0x3f,
+            ),
+        "/cs  <U";
+    is $c, 0x124, "/cs  <U count";
+
+    $s = $all255_twice_plus;
+    $c = $s =~ tr/\x40-\xbf\xf0-\xff/\x80-\xbf\x00-\x3f/csd;
+    is $s, join('', map chr, 0x80..0xbf,
+                (map  { ($_, $_) } 0x40..0xbf),
+                0x00..0x2f,
+                (map  { ($_, $_) } 0xf0..0xff),
+                0x30..0x3f,
+            ),
+        "/csd <U";
+    is $c, 0x120, "/csd <U count";
+}
+
+{
+    # RT #132608
+    # the 'extra length' for tr///c was stored as a short, so if the
+    # replacement string had more than 0x7fff chars not paired with
+    # search chars, bad things could happen
+
+    my ($c, $e, $s);
+
+    $s = "\x{9000}\x{9001}\x{9002}";
+    $e =    "\$c = \$s =~ tr/\\x00-\\xff/"
+          . ("ABCDEFGHIJKLMNO" x (0xa000 / 15))
+          . "/c; 1; ";
+    eval $e or die $@;
+    is $s, "IJK", "RT #132608 len=0xa000";
+    is $c, 3, "RT #132608 len=0xa000 count";
+
+    $s = "\x{9003}\x{9004}\x{9005}";
+    $e =    "\$c = \$s =~ tr/\\x00-\\xff/"
+          . ("ABCDEFGHIJKLMNO" x (0x12000 / 15))
+          . "/c; 1; ";
+    eval $e or die $@;
+    is $s, "LMN", "RT #132608 len=0x12000";
+    is $c, 3, "RT #132608 len=0x12000 count";
+}
+
+
 SKIP: {   # Test literal range end point special handling
     unless ($::IS_EBCDIC) {
         skip "Valid only for EBCDIC", 24;