This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Integrate changes #8378,8379,8385,8386,8405 from mainline.
authorJarkko Hietaniemi <jhi@iki.fi>
Sun, 28 Jan 2001 04:01:51 +0000 (04:01 +0000)
committerJarkko Hietaniemi <jhi@iki.fi>
Sun, 28 Jan 2001 04:01:51 +0000 (04:01 +0000)
Subject: One more patch for UTF8  (UTF-8 fixes for 'x' and tr////)

Subject: [ID 20001230.003] UTF-8 tr still hurts

Test cases for #8385 (from Simon's "torture.pl")

Start fixing UTF-8 lval substr() (8405)

p4raw-link: @8405 on //depot/perl: 075a4a2b17419f90b0888605cbb91ee4b236f645
p4raw-link: @8386 on //depot/perl: a1874b66a2e595b5c1284f57f900fb844c8d8fa3
p4raw-link: @8385 on //depot/perl: 16ec844ddf6ed30b884deee1be32522f7b107b77
p4raw-link: @8379 on //depot/perl: 381d18bc28cdc85893deda4f9cdd3088b5465500
p4raw-link: @8378 on //depot/perl: 9b877dbba0196ef7d4c6e2b0fcfc6e6f4955d526

p4raw-id: //depot/maint-5.6/perl@8575
p4raw-integrated: from //depot/perl@8574 'edit in' t/op/tr.t (@8379..)
p4raw-integrated: from //depot/perl@8405 'copy in' t/op/substr.t
(@7111..) 'merge in' mg.c (@8372..)
p4raw-integrated: from //depot/perl@8385 'edit in' doop.c (@8378..)
p4raw-integrated: from //depot/perl@8378 'ignore' pod/perlapi.pod
(@8267..) 'merge in' regcomp.c regexec.c (@8328..) toke.c
(@8343..) pp.c utf8.c (@8359..) op.c (@8363..) embed.h embed.pl
proto.h (@8372..)

13 files changed:
doop.c
embed.h
embed.pl
mg.c
op.c
pod/perlapi.pod
pp.c
proto.h
regexec.c
t/op/substr.t
t/op/tr.t
toke.c
utf8.c

diff --git a/doop.c b/doop.c
index 38761dc..dabbadd 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -28,6 +28,7 @@ S_do_trans_simple(pTHX_ SV *sv)
     U8 *send;
     U8 *dstart;
     I32 matches = 0;
+    I32 grows = PL_op->op_private & OPpTRANS_GROWS;
     STRLEN len;
     short *tbl;
     I32 ch;
@@ -54,16 +55,18 @@ S_do_trans_simple(pTHX_ SV *sv)
     }
 
     /* Allow for expansion: $_="a".chr(400); tr/a/\xFE/, FE needs encoding */
-    Newz(0, d, len*2+1, U8);
+    if (grows)
+       New(0, d, len*2+1, U8);
+    else
+       d = s;
     dstart = d;
     while (s < send) {
         STRLEN ulen;
-        short c;
+        UV c;
 
-        ulen = 1;
         /* Need to check this, otherwise 128..255 won't match */
        c = utf8_to_uv(s, send - s, &ulen, 0);
-        if (c < 0x100 && (ch = tbl[(short)c]) >= 0) {
+        if (c < 0x100 && (ch = tbl[c]) >= 0) {
             matches++;
             if (UTF8_IS_ASCII(ch))
                 *d++ = ch;
@@ -72,12 +75,19 @@ S_do_trans_simple(pTHX_ SV *sv)
             s += ulen;
         }
        else { /* No match -> copy */
-            while (ulen--)
-                *d++ = *s++;
+           Copy(s, d, ulen, U8);
+           d += ulen;
+           s += ulen;
         }
     }
-    *d = '\0';
-    sv_setpvn(sv, (char*)dstart, d - dstart);
+    if (grows) {
+       sv_setpvn(sv, (char*)dstart, d - dstart);
+       Safefree(dstart);
+    }
+    else {
+       *d = '\0';
+       SvCUR_set(sv, d - dstart);
+    }
     SvUTF8_on(sv);
     SvSETMAGIC(sv);
     return matches;
@@ -128,6 +138,7 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */
     U8 *dstart;
     I32 isutf8;
     I32 matches = 0;
+    I32 grows = PL_op->op_private & OPpTRANS_GROWS;
     STRLEN len;
     short *tbl;
     I32 ch;
@@ -174,7 +185,10 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */
        SvCUR_set(sv, d - dstart);
     }
     else { /* isutf8 */
-       Newz(0, d, len*2+1, U8);
+       if (grows)
+           New(0, d, len*2+1, U8);
+       else
+           d = s;
        dstart = d;
 
        if (PL_op->op_private & OPpTRANS_SQUASH) {
@@ -184,8 +198,10 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */
                STRLEN len;
                UV comp = utf8_to_uv_simple(s, &len);
 
-               if (comp > 0xff)
-                   d = uv_to_utf8(d, comp);    /* always unmapped */
+               if (comp > 0xff) {      /* always unmapped */   
+                   Copy(s, d, len, U8);
+                   d += len;
+               }
                else if ((ch = tbl[comp]) >= 0) {
                    matches++;
                    if (ch != pch) {
@@ -195,8 +211,10 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */
                    s += len;
                    continue;
                }
-               else if (ch == -1)      /* -1 is unmapped character */
-                   d = uv_to_utf8(d, comp);
+               else if (ch == -1) {    /* -1 is unmapped character */
+                   Copy(s, d, len, U8);
+                   d += len;
+               }
                else if (ch == -2)      /* -2 is delete character */
                    matches++;
                s += len;
@@ -207,22 +225,31 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */
            while (s < send) {
                STRLEN len;
                UV comp = utf8_to_uv_simple(s, &len);
-               if (comp > 0xff)
-                   d = uv_to_utf8(d, comp);    /* always unmapped */
+               if (comp > 0xff) {      /* always unmapped */
+                   Copy(s, d, len, U8);
+                   d += len;
+               }
                else if ((ch = tbl[comp]) >= 0) {
                    d = uv_to_utf8(d, ch);
                    matches++;
                }
                else if (ch == -1) {    /* -1 is unmapped character */
-                   d = uv_to_utf8(d, comp);
+                   Copy(s, d, len, U8);
+                   d += len;
                }
                else if (ch == -2)      /* -2 is delete character */
                    matches++;
                s += len;
            }
        }
-       *d = '\0';
-       sv_setpvn(sv, (char*)dstart, d - dstart);
+       if (grows) {
+           sv_setpvn(sv, (char*)dstart, d - dstart);
+           Safefree(dstart);
+       }
+       else {
+           *d = '\0';
+           SvCUR_set(sv, d - dstart);
+       }
        SvUTF8_on(sv);
     }
     SvSETMAGIC(sv);
@@ -239,6 +266,7 @@ S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */
     U8 *start;
     U8 *dstart, *dend;
     I32 matches = 0;
+    I32 grows = PL_op->op_private & OPpTRANS_GROWS;
     STRLEN len;
 
     SV* rv = (SV*)cSVOP->op_sv;
@@ -268,10 +296,16 @@ S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */
     if (svp)
        final = SvUV(*svp);
 
-    /* d needs to be bigger than s, in case e.g. upgrading is required */
-    New(0, d, len*3+UTF8_MAXLEN, U8);
-    dend = d + len * 3;
-    dstart = d;
+    if (grows) {
+       /* d needs to be bigger than s, in case e.g. upgrading is required */
+       New(0, d, len*3+UTF8_MAXLEN, U8);
+       dend = d + len * 3;
+       dstart = d;
+    }
+    else {
+       dstart = d = s;
+       dend = d + len;
+    }
 
     while (s < send) {
        if ((uv = swash_fetch(rv, s)) < none) {
@@ -281,8 +315,9 @@ S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */
        }
        else if (uv == none) {
            int i = UTF8SKIP(s);
-           while(i--)
-               *d++ = *s++;
+           Copy(s, d, i, U8);
+           d += i;
+           s += i;
        }
        else if (uv == extra) {
            int i = UTF8SKIP(s);
@@ -293,20 +328,28 @@ S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */
        else
            s += UTF8SKIP(s);
 
-       if (d >= dend) {
+       if (d > dend) {
            STRLEN clen = d - dstart;
            STRLEN nlen = dend - dstart + len + UTF8_MAXLEN;
+           if (!grows)
+               Perl_croak(aTHX_ "panic: do_trans_complex_utf8");
            Renew(dstart, nlen+UTF8_MAXLEN, U8);
            d = dstart + clen;
            dend = dstart + nlen;
        }
     }
-    *d = '\0';
-    sv_setpvn(sv, (char*)dstart, d - dstart);
+    if (grows || hibit) {
+       sv_setpvn(sv, (char*)dstart, d - dstart);
+       Safefree(dstart);
+       if (grows && hibit)
+           Safefree(start);
+    }
+    else {
+       *d = '\0';
+       SvCUR_set(sv, d - dstart);
+    }
     SvSETMAGIC(sv);
     SvUTF8_on(sv);
-    if (hibit)
-       Safefree(start);
     if (!isutf8 && !(PL_hints & HINT_UTF8))
        sv_utf8_downgrade(sv, TRUE);
 
@@ -361,6 +404,7 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */
     I32 matches = 0;
     I32 squash   = PL_op->op_private & OPpTRANS_SQUASH;
     I32 del      = PL_op->op_private & OPpTRANS_DELETE;
+    I32 grows    = PL_op->op_private & OPpTRANS_GROWS;
     SV* rv = (SV*)cSVOP->op_sv;
     HV* hv = (HV*)SvRV(rv);
     SV** svp = hv_fetch(hv, "NONE", 4, FALSE);
@@ -390,17 +434,27 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */
     if (svp)
        final = SvUV(*svp);
 
-    New(0, d, len*3+UTF8_MAXLEN, U8);
-    dend = d + len * 3;
-    dstart = d;
+    if (grows) {
+       /* d needs to be bigger than s, in case e.g. upgrading is required */
+       New(0, d, len*3+UTF8_MAXLEN, U8);
+       dend = d + len * 3;
+       dstart = d;
+    }
+    else {
+       dstart = d = s;
+       dend = d + len;
+    }
 
     if (squash) {
        UV puv = 0xfeedface;
        while (s < send) {
            uv = swash_fetch(rv, s);
            
-           if (d >= dend) {
-               STRLEN clen = d - dstart, nlen = dend - dstart + len;
+           if (d > dend) {
+               STRLEN clen = d - dstart;
+               STRLEN nlen = dend - dstart + len + UTF8_MAXLEN;
+               if (!grows)
+                   Perl_croak(aTHX_ "panic: do_trans_complex_utf8");
                Renew(dstart, nlen+UTF8_MAXLEN, U8);
                d = dstart + clen;
                dend = dstart + nlen;
@@ -416,8 +470,9 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */
            }
            else if (uv == none) {      /* "none" is unmapped character */
                int i = UTF8SKIP(s);
-               while(i--)
-                   *d++ = *s++;
+               Copy(s, d, i, U8);
+               d += i;
+               s += i;
                puv = 0xfeedface;
                continue;
            }
@@ -437,8 +492,11 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */
     else {
        while (s < send) {
            uv = swash_fetch(rv, s);
-           if (d >= dend) {
-               STRLEN clen = d - dstart, nlen = dend - dstart + len;
+           if (d > dend) {
+               STRLEN clen = d - dstart;
+               STRLEN nlen = dend - dstart + len + UTF8_MAXLEN;
+               if (!grows)
+                   Perl_croak(aTHX_ "panic: do_trans_complex_utf8");
                Renew(dstart, nlen+UTF8_MAXLEN, U8);
                d = dstart + clen;
                dend = dstart + nlen;
@@ -451,8 +509,9 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */
            }
            else if (uv == none) {      /* "none" is unmapped character */
                int i = UTF8SKIP(s);
-               while(i--)
-                   *d++ = *s++;
+               Copy(s, d, i, U8);
+               d += i;
+               s += i;
                continue;
            }
            else if (uv == extra && !del) {
@@ -465,11 +524,17 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */
            s += UTF8SKIP(s);
        }
     }
-    *d = '\0';
-    sv_setpvn(sv, (char*)dstart, d - dstart);
+    if (grows || hibit) {
+       sv_setpvn(sv, (char*)dstart, d - dstart);
+       Safefree(dstart);
+       if (grows && hibit)
+           Safefree(start);
+    }
+    else {
+       *d = '\0';
+       SvCUR_set(sv, d - dstart);
+    }
     SvUTF8_on(sv);
-    if (hibit)
-       Safefree(start);
     if (!isutf8 && !(PL_hints & HINT_UTF8))
        sv_utf8_downgrade(sv, TRUE);
     SvSETMAGIC(sv);
diff --git a/embed.h b/embed.h
index 8e0ab17..598b574 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define scalarboolean          S_scalarboolean
 #define too_few_arguments      S_too_few_arguments
 #define too_many_arguments     S_too_many_arguments
+#define trlist_upgrade         S_trlist_upgrade
 #define op_clear               S_op_clear
 #define null                   S_null
 #define pad_addlex             S_pad_addlex
 #define scalarboolean(a)       S_scalarboolean(aTHX_ a)
 #define too_few_arguments(a,b) S_too_few_arguments(aTHX_ a,b)
 #define too_many_arguments(a,b)        S_too_many_arguments(aTHX_ a,b)
+#define trlist_upgrade(a,b)    S_trlist_upgrade(aTHX_ a,b)
 #define op_clear(a)            S_op_clear(aTHX_ a)
 #define null(a)                        S_null(aTHX_ a)
 #define pad_addlex(a)          S_pad_addlex(aTHX_ a)
 #define too_few_arguments      S_too_few_arguments
 #define S_too_many_arguments   CPerlObj::S_too_many_arguments
 #define too_many_arguments     S_too_many_arguments
+#define S_trlist_upgrade       CPerlObj::S_trlist_upgrade
+#define trlist_upgrade         S_trlist_upgrade
 #define S_op_clear             CPerlObj::S_op_clear
 #define op_clear               S_op_clear
 #define S_null                 CPerlObj::S_null
index e815a44..7b5f175 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -2254,6 +2254,7 @@ s |OP*    |no_fh_allowed  |OP *o
 s      |OP*    |scalarboolean  |OP *o
 s      |OP*    |too_few_arguments|OP *o|char* name
 s      |OP*    |too_many_arguments|OP *o|char* name
+s      |U8*    |trlist_upgrade |U8** sp|U8** ep
 s      |void   |op_clear       |OP* o
 s      |void   |null           |OP* o
 s      |PADOFFSET|pad_addlex   |SV* name
diff --git a/mg.c b/mg.c
index fd811ad..afdf5ee 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -1420,15 +1420,25 @@ Perl_magic_getsubstr(pTHX_ SV *sv, MAGIC *mg)
 int
 Perl_magic_setsubstr(pTHX_ SV *sv, MAGIC *mg)
 {
-    STRLEN len;
-    char *tmps = SvPV(sv,len);
+    STRLEN littlelen;
+    char *tmps = SvPV(sv, littlelen);
+
     if (DO_UTF8(sv)) {
+       I32 bigoff = LvTARGOFF(sv);
+       I32 biglen = LvTARGLEN(sv);
+       U8 *s, *a, *b;
+
        sv_utf8_upgrade(LvTARG(sv));
-       sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
+       /* sv_utf8_upgrade() might have moved and/or resized
+        * the string to be replaced, we must rediscover it. --jhi */
+       s = (U8*)SvPVX(LvTARG(sv));
+       a = utf8_hop(s, bigoff);
+       b = utf8_hop(a, biglen);
+       sv_insert(LvTARG(sv), a - s, b - a, tmps, littlelen);
        SvUTF8_on(LvTARG(sv));
     }
     else
-        sv_insert(LvTARG(sv),LvTARGOFF(sv),LvTARGLEN(sv), tmps, len);
+        sv_insert(LvTARG(sv), LvTARGOFF(sv), LvTARGLEN(sv), tmps, littlelen);
 
     return 0;
 }
diff --git a/op.c b/op.c
index fab1de9..f0e8074 100644 (file)
--- a/op.c
+++ b/op.c
@@ -102,6 +102,30 @@ S_no_bareword_allowed(pTHX_ OP *o)
                     SvPV_nolen(cSVOPo_sv)));
 }
 
+STATIC U8*
+S_trlist_upgrade(pTHX_ U8** sp, U8** ep)
+{
+    U8 *s = *sp;
+    U8 *e = *ep;
+    U8 *d;
+
+    Newz(801, d, (e - s) * 2, U8);
+    *sp = d;
+
+    while (s < e) {
+        if (*s < 0x80 || *s == 0xff)
+            *d++ = *s++;
+       else {
+            U8 c = *s++;
+            *d++ = ((c >> 6)         | 0xc0);
+            *d++ = ((c       & 0x3f) | 0x80);
+        }
+    }
+    *ep = d;
+    return *sp;
+}
+  
+
 /* "register" allocation */
 
 PADOFFSET
@@ -2595,13 +2619,14 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
     SV *rstr = ((SVOP*)repl)->op_sv;
     STRLEN tlen;
     STRLEN rlen;
-    register U8 *t = (U8*)SvPV(tstr, tlen);
-    register U8 *r = (U8*)SvPV(rstr, rlen);
+    U8 *t = (U8*)SvPV(tstr, tlen);
+    U8 *r = (U8*)SvPV(rstr, rlen);
     register I32 i;
     register I32 j;
     I32 del;
     I32 complement;
     I32 squash;
+    I32 grows = 0;
     register short *tbl;
 
     complement = o->op_private & OPpTRANS_COMPLEMENT;
@@ -2630,11 +2655,12 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
        I32 none = 0;
        U32 max = 0;
        I32 bits;
-       I32 grows = 0;
        I32 havefinal = 0;
        U32 final;
        I32 from_utf    = o->op_private & OPpTRANS_FROM_UTF;
        I32 to_utf      = o->op_private & OPpTRANS_TO_UTF;
+       U8* tsave = from_utf ? NULL : trlist_upgrade(&t, &tend);
+       U8* rsave = to_utf   ? NULL : trlist_upgrade(&r, &rend);
 
        if (complement) {
            U8 tmpbuf[UTF8_MAXLEN+1];
@@ -2756,20 +2782,8 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
                if (rfirst + diff > max)
                    max = rfirst + diff;
                rfirst += diff + 1;
-               if (!grows) {
-                   if (rfirst <= 0x80)
-                       ;
-                   else if (rfirst <= 0x800)
-                       grows |= (tfirst < 0x80);
-                   else if (rfirst <= 0x10000)
-                       grows |= (tfirst < 0x800);
-                   else if (rfirst <= 0x200000)
-                       grows |= (tfirst < 0x10000);
-                   else if (rfirst <= 0x4000000)
-                       grows |= (tfirst < 0x200000);
-                   else if (rfirst <= 0x80000000)
-                       grows |= (tfirst < 0x4000000);
-               }
+               if (!grows)
+                   grows = (UNISKIP(tfirst) < UNISKIP(rfirst));
            }
            tfirst += diff + 1;
        }
@@ -2794,9 +2808,14 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5,
                           newSVuv((UV)final), 0);
 
-       if (grows && to_utf)
+       if (grows)
            o->op_private |= OPpTRANS_GROWS;
 
+       if (tsave)
+           Safefree(tsave);
+       if (rsave)
+           Safefree(rsave);
+
        op_free(expr);
        op_free(repl);
        return o;
@@ -2817,8 +2836,11 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
                    else
                        tbl[i] = i;
                }
-               else
+               else {
+                   if (i < 128 && r[j] >= 128)
+                       grows = 1;
                    tbl[i] = r[j++];
+               }
            }
        }
     }
@@ -2839,10 +2861,15 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
                }
                --j;
            }
-           if (tbl[t[i]] == -1)
+           if (tbl[t[i]] == -1) {
+               if (t[i] < 128 && r[j] >= 128)
+                   grows = 1;
                tbl[t[i]] = r[j];
+           }
        }
     }
+    if (grows)
+       o->op_private |= OPpTRANS_GROWS;
     op_free(expr);
     op_free(repl);
 
index 9f00c3c..24f0485 100644 (file)
@@ -1165,7 +1165,7 @@ eligible for inlining at compile-time.
        void    newCONSTSUB(HV* stash, char* name, SV* sv)
 
 =for hackers
-Found in file op.c
+Found in file opmini.c
 
 =item newHV
 
@@ -1298,7 +1298,7 @@ Found in file sv.c
 Used by C<xsubpp> to hook up XSUBs as Perl subs.
 
 =for hackers
-Found in file op.c
+Found in file opmini.c
 
 =item newXSproto
 
@@ -2546,8 +2546,9 @@ Found in file sv.c
 
 =item sv_catsv
 
-Concatenates the string from SV C<ssv> onto the end of the string in SV
-C<dsv>.  Handles 'get' magic, but not 'set' magic.  See C<sv_catsv_mg>.
+Concatenates the string from SV C<ssv> onto the end of the string in
+SV C<dsv>.  Modifies C<dsv> but not C<ssv>.  Handles 'get' magic, but
+not 'set' magic.  See C<sv_catsv_mg>.
 
        void    sv_catsv(SV* dsv, SV* ssv)
 
@@ -3231,8 +3232,7 @@ Found in file utf8.c
 
 Returns the character value of the first character in the string C<s>
 which is assumed to be in UTF8 encoding and no longer than C<curlen>;
-C<retlen> will be set to the length, in bytes, of that character,
-and the pointer C<s> will be advanced to the end of the character.
+C<retlen> will be set to the length, in bytes, of that character.
 
 If C<s> does not point to a well-formed UTF8 character, the behaviour
 is dependent on the value of C<flags>: if it contains UTF8_CHECK_ONLY,
@@ -3254,8 +3254,7 @@ Found in file utf8.c
 
 Returns the character value of the first character in the string C<s>
 which is assumed to be in UTF8 encoding; C<retlen> will be set to the
-length, in bytes, of that character, and the pointer C<s> will be
-advanced to the end of the character.
+length, in bytes, of that character.
 
 If C<s> does not point to a well-formed UTF8 character, zero is
 returned and retlen is set, if possible, to -1.
diff --git a/pp.c b/pp.c
index 32db9e6..edee6ce 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -1082,10 +1082,11 @@ PP(pp_repeat)
     else {     /* Note: mark already snarfed by pp_list */
        SV *tmpstr = POPs;
        STRLEN len;
-       bool isutf = DO_UTF8(tmpstr);
+       bool isutf;
 
        SvSetSV(TARG, tmpstr);
        SvPV_force(TARG, len);
+       isutf = DO_UTF8(TARG);
        if (count != 1) {
            if (count < 1)
                SvCUR_set(TARG, 0);
diff --git a/proto.h b/proto.h
index c7c88a6..33c2d32 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1001,6 +1001,7 @@ STATIC OP*        S_no_fh_allowed(pTHX_ OP *o);
 STATIC OP*     S_scalarboolean(pTHX_ OP *o);
 STATIC OP*     S_too_few_arguments(pTHX_ OP *o, char* name);
 STATIC OP*     S_too_many_arguments(pTHX_ OP *o, char* name);
+STATIC U8*     S_trlist_upgrade(pTHX_ U8** sp, U8** ep);
 STATIC void    S_op_clear(pTHX_ OP* o);
 STATIC void    S_null(pTHX_ OP* o);
 STATIC PADOFFSET       S_pad_addlex(pTHX_ SV* name);
index b3d281b..b02edd8 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -456,6 +456,8 @@ Perl_re_intuit_start(pTHX_ regexp *prog, SV *sv, char *strpos,
 #endif
 
   restart:
+    other_last = Nullch;
+
     /* Find a possible match in the region s..strend by looking for
        the "check" substring in the region corrected by start/end_shift. */
     if (flags & REXEC_SCREAM) {
index 4d3bbce..d3937fb 100755 (executable)
@@ -1,6 +1,6 @@
 #!./perl
 
-print "1..136\n";
+print "1..149\n";
 
 #P = start of string  Q = start of substr  R = end of substr  S = end of string
 
@@ -304,3 +304,128 @@ my %data;
 tie $data{'a'}, 'Tie::StdScalar';  # makes $data{'a'} magical
 $data{a} = "firstlast";
 ok 136, substr($data{'a'}, 0, 5, "") eq "first" && $data{'a'} eq "last";
+
+# more utf8
+
+# The following two originally from Ignasi Roca.
+
+$x = "\xF1\xF2\xF3";
+substr($x, 0, 1) = "\x{100}"; # Ignasi had \x{FF}
+ok 137, length($x) == 3 &&
+        $x eq "\x{100}\xF2\xF3" &&
+        substr($x, 0, 1) eq "\x{100}" &&
+        substr($x, 1, 1) eq "\x{F2}" &&
+        substr($x, 2, 1) eq "\x{F3}";
+
+$x = "\xF1\xF2\xF3";
+substr($x, 0, 1) = "\x{100}\x{FF}"; # Ignasi had \x{FF}
+ok 138, length($x) == 4 &&
+        $x eq "\x{100}\x{FF}\xF2\xF3" &&
+        substr($x, 0, 1) eq "\x{100}" &&
+        substr($x, 1, 1) eq "\x{FF}" &&
+        substr($x, 2, 1) eq "\x{F2}" &&
+        substr($x, 3, 1) eq "\x{F3}";
+
+# more utf8 lval exercise
+
+$x = "\xF1\xF2\xF3";
+substr($x, 0, 2) = "\x{100}\xFF";
+ok 139, length($x) == 3 &&
+        $x eq "\x{100}\xFF\xF3" &&
+        substr($x, 0, 1) eq "\x{100}" &&
+        substr($x, 1, 1) eq "\x{FF}" &&
+        substr($x, 2, 1) eq "\x{F3}";
+
+$x = "\xF1\xF2\xF3";
+substr($x, 1, 1) = "\x{100}\xFF";
+ok 140, length($x) == 4 &&
+        $x eq "\xF1\x{100}\xFF\xF3" &&
+        substr($x, 0, 1) eq "\x{F1}" &&
+        substr($x, 1, 1) eq "\x{100}" &&
+        substr($x, 2, 1) eq "\x{FF}" &&
+        substr($x, 3, 1) eq "\x{F3}";
+
+$x = "\xF1\xF2\xF3";
+substr($x, 2, 1) = "\x{100}\xFF";
+ok 141, length($x) == 4 &&
+        $x eq "\xF1\xF2\x{100}\xFF" &&
+        substr($x, 0, 1) eq "\x{F1}" &&
+        substr($x, 1, 1) eq "\x{F2}" &&
+        substr($x, 2, 1) eq "\x{100}" &&
+        substr($x, 3, 1) eq "\x{FF}";
+
+$x = "\xF1\xF2\xF3";
+substr($x, 3, 1) = "\x{100}\xFF";
+ok 142, length($x) == 5 &&
+        $x eq "\xF1\xF2\xF3\x{100}\xFF" &&
+        substr($x, 0, 1) eq "\x{F1}" &&
+        substr($x, 1, 1) eq "\x{F2}" &&
+        substr($x, 2, 1) eq "\x{F3}" &&
+        substr($x, 3, 1) eq "\x{100}" &&
+        substr($x, 4, 1) eq "\x{FF}";
+
+$x = "\xF1\xF2\xF3";
+substr($x, -1, 1) = "\x{100}\xFF";
+ok 143, length($x) == 4 &&
+        $x eq "\xF1\xF2\x{100}\xFF" &&
+        substr($x, 0, 1) eq "\x{F1}" &&
+        substr($x, 1, 1) eq "\x{F2}" &&
+        substr($x, 2, 1) eq "\x{100}" &&
+        substr($x, 3, 1) eq "\x{FF}";
+
+$x = "\xF1\xF2\xF3";
+substr($x, -1, 0) = "\x{100}\xFF";
+ok 144, length($x) == 5 &&
+        $x eq "\xF1\xF2\x{100}\xFF\xF3" &&
+        substr($x, 0, 1) eq "\x{F1}" &&
+        substr($x, 1, 1) eq "\x{F2}" &&
+        substr($x, 2, 1) eq "\x{100}" &&
+        substr($x, 3, 1) eq "\x{FF}" &&
+        substr($x, 4, 1) eq "\x{F3}";
+
+$x = "\xF1\xF2\xF3";
+substr($x, 0, -1) = "\x{100}\xFF";
+ok 145, length($x) == 3 &&
+        $x eq "\x{100}\xFF\xF3" &&
+        substr($x, 0, 1) eq "\x{100}" &&
+        substr($x, 1, 1) eq "\x{FF}" &&
+        substr($x, 2, 1) eq "\x{F3}";
+
+$x = "\xF1\xF2\xF3";
+substr($x, 0, -2) = "\x{100}\xFF";
+ok 146, length($x) == 4 &&
+        $x eq "\x{100}\xFF\xF2\xF3" &&
+        substr($x, 0, 1) eq "\x{100}" &&
+        substr($x, 1, 1) eq "\x{FF}" &&
+        substr($x, 2, 1) eq "\x{F2}" &&
+        substr($x, 3, 1) eq "\x{F3}";
+
+$x = "\xF1\xF2\xF3";
+substr($x, 0, -3) = "\x{100}\xFF";
+ok 147, length($x) == 5 &&
+        $x eq "\x{100}\xFF\xF1\xF2\xF3" &&
+        substr($x, 0, 1) eq "\x{100}" &&
+        substr($x, 1, 1) eq "\x{FF}" &&
+        substr($x, 2, 1) eq "\x{F1}" &&
+        substr($x, 3, 1) eq "\x{F2}" &&
+        substr($x, 4, 1) eq "\x{F3}";
+
+$x = "\xF1\xF2\xF3";
+substr($x, 1, -1) = "\x{100}\xFF";
+ok 148, length($x) == 4 &&
+        $x eq "\xF1\x{100}\xFF\xF3" &&
+        substr($x, 0, 1) eq "\x{F1}" &&
+        substr($x, 1, 1) eq "\x{100}" &&
+        substr($x, 2, 1) eq "\x{FF}" &&
+        substr($x, 3, 1) eq "\x{F3}";
+
+$x = "\xF1\xF2\xF3";
+substr($x, -1, -1) = "\x{100}\xFF";
+ok 149, length($x) == 5 &&
+        $x eq "\xF1\xF2\x{100}\xFF\xF3" &&
+        substr($x, 0, 1) eq "\x{F1}" &&
+        substr($x, 1, 1) eq "\x{F2}" &&
+        substr($x, 2, 1) eq "\x{100}" &&
+        substr($x, 3, 1) eq "\x{FF}" &&
+        substr($x, 4, 1) eq "\x{F3}";
+
index ad5c202..b1f4daf 100755 (executable)
--- a/t/op/tr.t
+++ b/t/op/tr.t
@@ -5,7 +5,7 @@ BEGIN {
     @INC = '../lib';
 }
 
-print "1..29\n";
+print "1..49\n";
 
 $_ = "abcdefghijklmnopqrstuvwxyz";
 
@@ -181,3 +181,109 @@ eval '"123" =~ tr/1/1/';
 print (($@ =~ m|^Can't modify constant item in transliteration \(tr///\)|)
        ? '' : 'not ', "ok 29\n");
 
+# v300 (0x12c) is UTF-8-encoded as 196 172 (0xc4 0xac)
+# v400 (0x190) is UTF-8-encoded as 198 144 (0xc6 0x90)
+
+# Transliterate a byte to a byte, all four ways.
+
+($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/;
+print "not " unless $a eq v300.197.172.300.197.172;
+print "ok 30\n";
+
+($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{c5}/;
+print "not " unless $a eq v300.197.172.300.197.172;
+print "ok 31\n";
+
+($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\xc5/;
+print "not " unless $a eq v300.197.172.300.197.172;
+print "ok 32\n";
+
+($a = v300.196.172.300.196.172) =~ tr/\x{c4}/\x{c5}/;
+print "not " unless $a eq v300.197.172.300.197.172;
+print "ok 33\n";
+
+# Transliterate a byte to a wide character.
+
+($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/;
+print "not " unless $a eq v300.301.172.300.301.172;
+print "ok 34\n";
+
+# Transliterate a wide character to a byte.
+
+($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc3/;
+print "not " unless $a eq v195.196.172.195.196.172;
+print "ok 35\n";
+
+# Transliterate a wide character to a wide character.
+
+($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/;
+print "not " unless $a eq v301.196.172.301.196.172;
+print "ok 36\n";
+
+# Transliterate both ways.
+
+($a = v300.196.172.300.196.172) =~ tr/\xc4\x{12c}/\x{12d}\xc3/;
+print "not " unless $a eq v195.301.172.195.301.172;
+print "ok 37\n";
+
+# Transliterate all (four) ways.
+
+($a = v300.196.172.300.196.172.400.198.144) =~
+       tr/\xac\xc4\x{12c}\x{190}/\xad\x{12d}\xc5\x{191}/;
+print "not " unless $a eq v197.301.173.197.301.173.401.198.144;
+print "ok 38\n";
+
+# Transliterate and count.
+
+print "not "
+    unless (($a = v300.196.172.300.196.172) =~ tr/\xc4/\xc5/)       == 2;
+print "ok 39\n";
+
+print "not "
+    unless (($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\x{12d}/) == 2;
+print "ok 40\n";
+
+# Transliterate with complement.
+
+($a = v300.196.172.300.196.172) =~ tr/\xc4/\x{12d}/c;
+print "not " unless $a eq v301.196.301.301.196.301;
+print "ok 41\n";
+
+($a = v300.196.172.300.196.172) =~ tr/\x{12c}/\xc5/c;
+print "not " unless $a eq v300.197.197.300.197.197;
+print "ok 42\n";
+
+# Transliterate with deletion.
+
+($a = v300.196.172.300.196.172) =~ tr/\xc4//d;
+print "not " unless $a eq v300.172.300.172;
+print "ok 43\n";
+
+($a = v300.196.172.300.196.172) =~ tr/\x{12c}//d;
+print "not " unless $a eq v196.172.196.172;
+print "ok 44\n";
+
+# Transliterate with squeeze.
+
+($a = v196.196.172.300.300.196.172) =~ tr/\xc4/\xc5/s;
+print "not " unless $a eq v197.172.300.300.197.172;
+print "ok 45\n";
+
+($a = v196.172.300.300.196.172.172) =~ tr/\x{12c}/\x{12d}/s;
+print "not " unless $a eq v196.172.301.196.172.172;
+print "ok 46\n";
+
+# Tricky cases by Simon Cozens.
+
+($a = v196.172.200) =~ tr/\x{12c}/a/;
+print "not " unless sprintf("%vd", $a) eq '196.172.200';
+print "ok 47\n";
+
+($a = v196.172.200) =~ tr/\x{12c}/\x{12c}/;
+print "not " unless sprintf("%vd", $a) eq '196.172.200';
+print "ok 48\n";
+
+($a = v196.172.200) =~ tr/\x{12c}//d;
+print "not " unless sprintf("%vd", $a) eq '196.172.200';
+print "ok 49\n";
+
diff --git a/toke.c b/toke.c
index 66d0f1d..671ff29 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -1419,8 +1419,6 @@ S_scan_const(pTHX_ char *start)
                        if (hicount) {
                            char *old_pvx = SvPVX(sv);
                            char *src, *dst;
-                           U8 tmpbuf[UTF8_MAXLEN+1];
-                           U8 *tmpend;
                          
                            d = SvGROW(sv,
                                       SvCUR(sv) + hicount + 1) +
@@ -1432,10 +1430,8 @@ S_scan_const(pTHX_ char *start)
 
                            while (src < dst) {
                                if (UTF8_IS_CONTINUED(*src)) {
-                                   tmpend = uv_to_utf8(tmpbuf, (U8)*src--);
-                                   dst -= tmpend - tmpbuf;
-                                   Copy((char *)tmpbuf, dst+1,
-                                        tmpend - tmpbuf, char);
+                                   *dst-- = UTF8_EIGHT_BIT_LO(*src);
+                                   *dst-- = UTF8_EIGHT_BIT_HI(*src--);
                                }
                                else {
                                    *dst-- = *src--;
@@ -1444,7 +1440,7 @@ S_scan_const(pTHX_ char *start)
                         }
                     }
 
-                    if (to_be_utf8 || (has_utf8 && uv > 127) || uv > 255) {
+                   if (to_be_utf8 || has_utf8 || uv > 255) {
                        d = (char*)uv_to_utf8((U8*)d, uv);
                        has_utf8 = TRUE;
                     }
diff --git a/utf8.c b/utf8.c
index 33fce24..4005245 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -31,20 +31,17 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) /* the d must be UTF8_MAXLEN+1 deep */
 {
     if (uv < 0x80) {
        *d++ = uv;
-       *d   = 0;
        return d;
     }
     if (uv < 0x800) {
        *d++ = (( uv >>  6)         | 0xc0);
        *d++ = (( uv        & 0x3f) | 0x80);
-       *d   = 0;
        return d;
     }
     if (uv < 0x10000) {
        *d++ = (( uv >> 12)         | 0xe0);
        *d++ = (((uv >>  6) & 0x3f) | 0x80);
        *d++ = (( uv        & 0x3f) | 0x80);
-       *d   = 0;
        return d;
     }
     if (uv < 0x200000) {
@@ -52,7 +49,6 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) /* the d must be UTF8_MAXLEN+1 deep */
        *d++ = (((uv >> 12) & 0x3f) | 0x80);
        *d++ = (((uv >>  6) & 0x3f) | 0x80);
        *d++ = (( uv        & 0x3f) | 0x80);
-       *d   = 0;
        return d;
     }
     if (uv < 0x4000000) {
@@ -61,7 +57,6 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) /* the d must be UTF8_MAXLEN+1 deep */
        *d++ = (((uv >> 12) & 0x3f) | 0x80);
        *d++ = (((uv >>  6) & 0x3f) | 0x80);
        *d++ = (( uv        & 0x3f) | 0x80);
-       *d   = 0;
        return d;
     }
     if (uv < 0x80000000) {
@@ -71,7 +66,6 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) /* the d must be UTF8_MAXLEN+1 deep */
        *d++ = (((uv >> 12) & 0x3f) | 0x80);
        *d++ = (((uv >>  6) & 0x3f) | 0x80);
        *d++ = (( uv        & 0x3f) | 0x80);
-       *d   = 0;
        return d;
     }
 #ifdef HAS_QUAD
@@ -85,7 +79,6 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) /* the d must be UTF8_MAXLEN+1 deep */
        *d++ = (((uv >> 12) & 0x3f) | 0x80);
        *d++ = (((uv >>  6) & 0x3f) | 0x80);
        *d++ = (( uv        & 0x3f) | 0x80);
-       *d   = 0;
        return d;
     }
 #ifdef HAS_QUAD
@@ -103,7 +96,6 @@ Perl_uv_to_utf8(pTHX_ U8 *d, UV uv) /* the d must be UTF8_MAXLEN+1 deep */
        *d++ = (((uv >> 12) & 0x3f) | 0x80);
        *d++ = (((uv >>  6) & 0x3f) | 0x80);
        *d++ = (( uv        & 0x3f) | 0x80);
-       *d   = 0;
        return d;
     }
 #endif