X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=doop.c;h=3c344250750d338dbd48c7c64576d85eb11e9b1c;hb=db332f3bb66861fe23fc47f86cbb0a2d9ea03129;hp=9fd7dfa49fab8e4302e87db66e21c71d2a876876;hpb=287eef1b08ebb0e1197065c3c079b4a2d7ee452b;p=p5sagit%2Fp5-mst-13.2.git diff --git a/doop.c b/doop.c index 9fd7dfa..3c34425 100644 --- a/doop.c +++ b/doop.c @@ -144,6 +144,7 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */ U8 *s; U8 *send; U8 *d; + U8 *dstart; I32 hasutf = SvUTF8(sv); I32 matches = 0; STRLEN len; @@ -157,7 +158,9 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */ s = (U8*)SvPV(sv, len); send = s + len; - d = s; + Newz(0, d, len*2+1, U8); + dstart = d; + if (PL_op->op_private & OPpTRANS_SQUASH) { U8* p = send; @@ -168,9 +171,7 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */ if ((ch = tbl[*s]) >= 0) { *d = ch; matches++; - if (p == d - 1 && *p == *d) - matches--; - else + if (p != d - 1 || *p != *d) p = d++; } else if (ch == -1) /* -1 is unmapped character */ @@ -181,26 +182,41 @@ S_do_trans_complex(pTHX_ SV *sv)/* SPC - NOT OK */ } else { while (s < send) { + UV comp; if (hasutf && *s & 0x80) - s += UTF8SKIP(s); - else { - if ((ch = tbl[*s]) >= 0) { - *d = ch; - matches++; - d++; - } - else if (ch == -1) /* -1 is unmapped character */ - *d++ = *s; /* -2 is delete character */ - s++; - } + comp = utf8_to_uv_simple(s, NULL); + else + comp = *s; + + ch = tbl[comp]; + + if (ch == -1) { /* -1 is unmapped character */ + ch = comp; + matches--; + } + + if (ch >= 0) { + if (hasutf) + d = uv_to_utf8(d, ch); + else + *d++ = ch; + } + matches++; + + s += hasutf && *s & 0x80 ? UNISKIP(*s) : 1; + } } - matches += send - d; /* account for disappeared chars */ + *d = '\0'; - SvCUR_set(sv, d - (U8*)SvPVX(sv)); - SvSETMAGIC(sv); + sv_setpvn(sv, (const char*)dstart, d - dstart); + Safefree(dstart); + if (hasutf) + SvUTF8_on(sv); + SvSETMAGIC(sv); return matches; + } STATIC I32 @@ -926,7 +942,7 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) if (left_utf && !right_utf) sv_utf8_upgrade(right); - if (!left_utf && right_utf) + else if (!left_utf && right_utf) sv_utf8_upgrade(left); if (sv != left || (optype != OP_BIT_AND && !SvOK(sv) && !SvGMAGICAL(sv))) @@ -968,10 +984,10 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) switch (optype) { case OP_BIT_AND: while (lulen && rulen) { - luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANY); + luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); lc += ulen; lulen -= ulen; - ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANY); + ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV); rc += ulen; rulen -= ulen; duc = luc & ruc; @@ -983,10 +999,10 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) break; case OP_BIT_XOR: while (lulen && rulen) { - luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANY); + luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); lc += ulen; lulen -= ulen; - ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANY); + ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV); rc += ulen; rulen -= ulen; duc = luc ^ ruc; @@ -995,10 +1011,10 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) goto mop_up_utf; case OP_BIT_OR: while (lulen && rulen) { - luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANY); + luc = utf8_to_uv((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); lc += ulen; lulen -= ulen; - ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANY); + ruc = utf8_to_uv((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV); rc += ulen; rulen -= ulen; duc = luc | ruc;