This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Fix for "[ID 20010213.005] utf8 + localized hash elems + 64 bits?"
[perl5.git] / doop.c
diff --git a/doop.c b/doop.c
index 8256b93..f323069 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -1,6 +1,6 @@
 /*    doop.c
  *
- *    Copyright (c) 1991-2000, Larry Wall
+ *    Copyright (c) 1991-2001, Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -29,6 +29,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;
@@ -55,30 +56,36 @@ 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 (ch < 0x80)
-                *d++ = ch;
-            else
-                d = uv_to_utf8(d,ch);
+           d = uv_to_utf8(d, ch);
             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;
@@ -127,6 +134,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;
@@ -173,18 +181,26 @@ 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;
 
+#ifdef MACOS_TRADITIONAL
+#define comp CoMP   /* "comp" is a keyword in some compilers ... */
+#endif
+
        if (PL_op->op_private & OPpTRANS_SQUASH) {
-           U8* p = send;
            UV pch = 0xfeedface;
            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) {
                    matches++;
                    if (ch != pch) {
@@ -194,8 +210,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;
@@ -206,22 +224,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);
@@ -237,6 +264,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;
@@ -254,7 +282,7 @@ S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */
     if (!isutf8) {
        U8 *t = s, *e = s + len;
        while (t < e)
-           if ((hibit = *t++ & 0x80))
+           if ((hibit = UTF8_IS_CONTINUED(*t++)))
                break;
        if (hibit)
            s = bytes_to_utf8(s, &len);
@@ -266,10 +294,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) {
@@ -279,8 +313,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);
@@ -291,20 +326,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);
 
@@ -330,7 +373,7 @@ S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */
     if (!SvUTF8(sv)) {
        U8 *t = s, *e = s + len;
        while (t < e)
-           if ((hibit = *t++ & 0x80))
+           if ((hibit = !UTF8_IS_ASCII(*t++)))
                break;
        if (hibit)
            start = s = bytes_to_utf8(s, &len);
@@ -357,6 +400,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);
@@ -374,7 +418,7 @@ S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */
     if (!isutf8) {
        U8 *t = s, *e = s + len;
        while (t < e)
-           if ((hibit = *t++ & 0x80))
+           if ((hibit = !UTF8_IS_ASCII(*t++)))
                break;
        if (hibit)
            s = bytes_to_utf8(s, &len);
@@ -386,17 +430,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;
@@ -412,8 +466,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;
            }
@@ -433,8 +488,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;
@@ -447,8 +505,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) {
@@ -461,11 +520,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);
@@ -833,15 +898,15 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv)
            char *send = s + len;
            char *start = s;
            s = send - 1;
-           while ((*s & 0xc0) == 0x80)
-               --s;
-           if (UTF8SKIP(s) != send - s && ckWARN_d(WARN_UTF8))
-               Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
-           sv_setpvn(astr, s, send - s);
-           *s = '\0';
-           SvCUR_set(sv, s - start);
-           SvNIOK_off(sv);
-           SvUTF8_on(astr);
+           while (s > start && UTF8_IS_CONTINUATION(*s))
+               s--;
+           if (utf8_to_uv_simple((U8*)s, 0)) {
+               sv_setpvn(astr, s, send - s);
+               *s = '\0';
+               SvCUR_set(sv, s - start);
+               SvNIOK_off(sv);
+               SvUTF8_on(astr);
+           }
        }
        else
            sv_setpvn(astr, "", 0);
@@ -1144,7 +1209,7 @@ Perl_do_kv(pTHX)
        dokeys = dovalues = TRUE;
 
     if (!hv) {
-       if (PL_op->op_flags & OPf_MOD) {        /* lvalue */
+       if (PL_op->op_flags & OPf_MOD || LVRET) {       /* lvalue */
            dTARGET;            /* make sure to clear its target here */
            if (SvTYPE(TARG) == SVt_PVLV)
                LvTARG(TARG) = Nullsv;
@@ -1163,7 +1228,7 @@ Perl_do_kv(pTHX)
        IV i;
        dTARGET;
 
-       if (PL_op->op_flags & OPf_MOD) {        /* lvalue */
+       if (PL_op->op_flags & OPf_MOD || LVRET) {       /* lvalue */
            if (SvTYPE(TARG) < SVt_PVLV) {
                sv_upgrade(TARG, SVt_PVLV);
                sv_magic(TARG, Nullsv, 'k', Nullch, 0);
Unnamed repository; edit this file 'description' to name the repository.