In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/08b6664b858b8fd4b5c0c27542763337b6d78e46?hp=11c9859f920c51ebb0f8e9913646e4216b06519c>
- Log ----------------------------------------------------------------- commit 08b6664b858b8fd4b5c0c27542763337b6d78e46 Author: Karl Williamson <[email protected]> Date: Wed Jun 7 14:52:52 2017 -0600 Use simple-minded approach to bitwise UTF-8 operations Commit 5d09ee1cb7b68f5e6fd15233bfe5048612e8f949 fatalized bitwise operations of operands with wide characters in them. It retained the regular UTF-8 handling, but throws an error when a wide character is encountered. But this code is complicated because of its original intended generality. It can essentially be ripped out, replaced by code that just downgrades the operand to non-UTF-8. Then we use the regular code to do the operation. In the complement case, that's all that need be done to mimic earlier behavior, as the result has not been in UTF-8. For the other operations, the result is simply upgraded to UTF-8. This removes quite a few lines of code, and now the UTF-8 handling uses the same tight loops as the non-UTF-8. Downgrading and upgrading had to be done specially before, but now they are done in tight loops, before the operation, and after the operation M doop.c M pp.c commit 7e99522f0b6c062201bce39342ac82ce222e634d Author: Karl Williamson <[email protected]> Date: Wed Jun 7 14:20:08 2017 -0600 t/op/bop.t: Re-add in some tests Commit 5d09ee1cb7b68f5e6fd15233bfe5048612e8f949 fatalized above 0xFF code points in the bitwise operators. It removed a bunch of tests in t/op/bop.t. I had independently been working on this task. An issue with removing such tests is are they there to be testing wide characters, or are they there to test UTF-8, and the use of above-FF was merely incidental? I had undertaken the tedious work of looking through the commits for all the tests that now fail to determine which category they were in. I concur mostly with the previous commit, but there were a few tests that I found that should have been retained, and modified to pass under the new scheme. This commit does that. Deprecated warnings no longer have to be turned off, as they were because of the previous tests that have now been removed. M t/op/bop.t commit fac71630f045e7ab325b37548d59b6558735e5c3 Author: Karl Williamson <[email protected]> Date: Wed Jun 7 13:31:10 2017 -0600 Update pods about bitwise UTF-8 above 0xFF being fatal M pod/perldeprecation.pod M pod/perlop.pod M pod/perlunicode.pod M pod/perluniintro.pod commit 55951dd7f3503c21c2f34146e50e6411317fd1b2 Author: Karl Williamson <[email protected]> Date: Sat Jun 3 08:34:56 2017 -0600 t/op/bop.t: Verify complement downgrades UTF-8. This adds a test for the existing result, so it doesn't get changed in the future by mistake. I make no claims that it should work this way. M t/op/bop.t commit b08562c6e3a8d216e85de7861b51c9a7f1db5532 Author: Karl Williamson <[email protected]> Date: Wed Jun 7 13:57:41 2017 -0600 t/op/bop.t: Verify bitwise & ^ | retain UTF-8 If one of the inputs is encoded in UTF-8, the behavior has been to have the output be also in UTF-8. This has not been really documented, but I think that is the way it should be. In any case, this commit adds tests to make sure it doesn't inadvertently get changed. M t/op/bop.t ----------------------------------------------------------------------- Summary of changes: doop.c | 148 +++++++++++------------------------------------- pod/perldeprecation.pod | 2 +- pod/perlop.pod | 14 ++--- pod/perlunicode.pod | 11 ++-- pod/perluniintro.pod | 12 ++-- pp.c | 44 +++----------- t/op/bop.t | 35 ++++++++++-- 7 files changed, 90 insertions(+), 176 deletions(-) diff --git a/doop.c b/doop.c index 9b525ae53b..dc6956ce04 100644 --- a/doop.c +++ b/doop.c @@ -1028,61 +1028,61 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) STRLEN lensave; const char *lsave; const char *rsave; - bool left_utf; - bool right_utf; STRLEN needlen = 0; + bool result_needs_to_be_utf8 = FALSE; PERL_ARGS_ASSERT_DO_VOP; if (sv != left || (optype != OP_BIT_AND && !SvOK(sv))) SvPVCLEAR(sv); /* avoid undef warning on |= and ^= */ if (sv == left) { - lsave = lc = SvPV_force_nomg(left, leftlen); + lc = SvPV_force_nomg(left, leftlen); } else { - lsave = lc = SvPV_nomg_const(left, leftlen); + lc = SvPV_nomg_const(left, leftlen); SvPV_force_nomg_nolen(sv); } - rsave = rc = SvPV_nomg_const(right, rightlen); + rc = SvPV_nomg_const(right, rightlen); /* This needs to come after SvPV to ensure that string overloading has fired off. */ - left_utf = DO_UTF8(left); - right_utf = DO_UTF8(right); - - if (left_utf && !right_utf) { - /* Avoid triggering overloading again by using temporaries. - Maybe there should be a variant of sv_utf8_upgrade that takes pvn - */ - right = newSVpvn_flags(rsave, rightlen, SVs_TEMP); - sv_utf8_upgrade(right); - rsave = rc = SvPV_nomg_const(right, rightlen); - right_utf = TRUE; + /* Create downgraded temporaries of any UTF-8 encoded operands */ + if (DO_UTF8(left)) { + bool utf8 = TRUE; + + result_needs_to_be_utf8 = TRUE; + + lc = (char *) bytes_from_utf8((const U8 *) lc, &leftlen, &utf8); + if (utf8) { + Perl_croak(aTHX_ fatal_above_ff_msg, PL_op_desc[optype]); + } + SAVEFREEPV(lc); } - else if (!left_utf && right_utf) { - left = newSVpvn_flags(lsave, leftlen, SVs_TEMP); - sv_utf8_upgrade(left); - lsave = lc = SvPV_nomg_const(left, leftlen); - left_utf = TRUE; + if (DO_UTF8(right)) { + bool utf8 = TRUE; + + result_needs_to_be_utf8 = TRUE; + + rc = (char *) bytes_from_utf8((const U8 *) rc, &rightlen, &utf8); + if (utf8) { + Perl_croak(aTHX_ fatal_above_ff_msg, PL_op_desc[optype]); + } + SAVEFREEPV(rc); } + lsave = lc; + rsave = rc; len = leftlen < rightlen ? leftlen : rightlen; lensave = len; SvCUR_set(sv, len); (void)SvPOK_only(sv); - if ((left_utf || right_utf) && (sv == left || sv == right)) { - needlen = optype == OP_BIT_AND ? len : leftlen + rightlen; - Newxz(dc, needlen + 1, char); - } - else if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) { + if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) { dc = SvPV_force_nomg_nolen(sv); if (SvLEN(sv) < len + 1) { dc = SvGROW(sv, len + 1); (void)memzero(dc + SvCUR(sv), len - SvCUR(sv) + 1); } - if (optype != OP_BIT_AND && (left_utf || right_utf)) - dc = SvGROW(sv, leftlen + rightlen + 1); } else { needlen = optype == OP_BIT_AND @@ -1091,93 +1091,7 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) sv_usepvn_flags(sv, dc, needlen, SV_HAS_TRAILING_NUL); dc = SvPVX(sv); /* sv_usepvn() calls Renew() */ } - if (left_utf || right_utf) { - char *dcorig = dc; - char *dcsave = NULL; - STRLEN lulen = leftlen; - STRLEN rulen = rightlen; - switch (optype) { - case OP_BIT_AND: - while (lulen && rulen) { - UV duc, luc, ruc; - STRLEN ulen; - luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); - lc += ulen; - lulen -= ulen; - ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV); - rc += ulen; - rulen -= ulen; - duc = luc & ruc; - dc = (char*)uvchr_to_utf8((U8*)dc, duc); - if (luc > 0xff || ruc > 0xff) { - Perl_croak(aTHX_ fatal_above_ff_msg, PL_op_desc[optype]); - } - } - if (sv == left || sv == right) - (void)sv_usepvn(sv, dcorig, needlen); - SvCUR_set(sv, dc - dcorig); - *SvEND(sv) = 0; - break; - case OP_BIT_XOR: - while (lulen && rulen) { - UV duc, luc, ruc; - STRLEN ulen; - luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); - lc += ulen; - lulen -= ulen; - ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV); - rc += ulen; - rulen -= ulen; - duc = luc ^ ruc; - dc = (char*)uvchr_to_utf8((U8*)dc, duc); - if (luc > 0xff || ruc > 0xff) { - Perl_croak(aTHX_ fatal_above_ff_msg, PL_op_desc[optype]); - } - } - goto mop_up_utf; - case OP_BIT_OR: - while (lulen && rulen) { - UV duc, luc, ruc; - STRLEN ulen; - luc = utf8n_to_uvchr((U8*)lc, lulen, &ulen, UTF8_ALLOW_ANYUV); - lc += ulen; - lulen -= ulen; - ruc = utf8n_to_uvchr((U8*)rc, rulen, &ulen, UTF8_ALLOW_ANYUV); - rc += ulen; - rulen -= ulen; - duc = luc | ruc; - dc = (char*)uvchr_to_utf8((U8*)dc, duc); - if (luc > 0xff || ruc > 0xff) { - Perl_croak(aTHX_ fatal_above_ff_msg, PL_op_desc[optype]); - } - } - mop_up_utf: - if (rulen) - dcsave = savepvn(rc, rulen); - else if (lulen) - dcsave = savepvn(lc, lulen); - if (sv == left || sv == right) - (void)sv_usepvn(sv, dcorig, needlen); /* uses Renew(); defaults to nomg */ - SvCUR_set(sv, dc - dcorig); - if (rulen) - sv_catpvn_nomg(sv, dcsave, rulen); - else if (lulen) - sv_catpvn_nomg(sv, dcsave, lulen); - else - *SvEND(sv) = '\0'; - Safefree(dcsave); - break; - default: - if (sv == left || sv == right) - Safefree(dcorig); - Perl_croak(aTHX_ "panic: do_vop called for op %u (%s)", - (unsigned)optype, PL_op_name[optype]); - } - SvUTF8_on(sv); - goto finish; - } - else #ifdef LIBERAL if (len >= sizeof(long)*4 && !((unsigned long)dc % sizeof(long)) && @@ -1224,7 +1138,6 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) len = remainder; } #endif - { switch (optype) { case OP_BIT_AND: while (len--) @@ -1256,8 +1169,11 @@ Perl_do_vop(pTHX_ I32 optype, SV *sv, SV *left, SV *right) break; } + + if (result_needs_to_be_utf8) { + sv_utf8_upgrade_nomg(sv); } - finish: + SvTAINT(sv); } diff --git a/pod/perldeprecation.pod b/pod/perldeprecation.pod index 4ec3182408..1f54d0e0be 100644 --- a/pod/perldeprecation.pod +++ b/pod/perldeprecation.pod @@ -395,7 +395,7 @@ This feature was deprecated in Perl 5.004, and will be fatal in Perl 5.28. The string bitwise operators, C<&>, C<|>, C<^>, and C<~>, treat their operands as strings of bytes. As such, values above 0xFF are nonsensical. Using such code points with these operators -was deprecated in Perl 5.24, and will be fatal in Perl 5.28. +was deprecated in Perl 5.24, and is fatal starting in Perl 5.28. =head3 In XS code, use of C<to_utf8_case()> diff --git a/pod/perlop.pod b/pod/perlop.pod index 6c754ca477..f981644f67 100644 --- a/pod/perlop.pod +++ b/pod/perlop.pod @@ -243,11 +243,8 @@ bits wide on a 64-bit platform, so if you are expecting a certain bit width, remember to use the C<"&"> operator to mask off the excess bits. X<~> X<negation, binary> -When complementing strings, if all characters have ordinal values under -256, then their complements will, also. But if they do not, all -characters will be in either 32- or 64-bit complements, depending on your -architecture. So for example, C<~"\x{3B1}"> is C<"\x{FFFF_FC4E}"> on -32-bit machines and C<"\x{FFFF_FFFF_FFFF_FC4E}"> on 64-bit machines. +Starting in Perl 5.28, it is a fatal error to try to complement a string +containing a character with an ordinal value above 255. If the experimental "bitwise" feature is enabled via S<C<use feature 'bitwise'>>, then unary C<"~"> always treats its argument as a number, and an @@ -3362,9 +3359,10 @@ strings: The assignment variants of these operators (C<&= |= ^= &.= |.= ^.=>) behave likewise under the feature. -The behavior of these operators is problematic (and subject to change) -if either or both of the strings are encoded in UTF-8 (see -L<perlunicode/Byte and Character Semantics>. +It is a fatal error if an operand contains a character whose ordinal +value is above 0xFF, and hence not expressible except in UTF-8. The +operation is performed on a non-UTF-8 copy for other operands encoded in +UTF-8. See L<perlunicode/Byte and Character Semantics>. See L<perlfunc/vec> for information on how to manipulate individual bits in a bit vector. diff --git a/pod/perlunicode.pod b/pod/perlunicode.pod index 9c13c35a9c..43f145918b 100644 --- a/pod/perlunicode.pod +++ b/pod/perlunicode.pod @@ -191,11 +191,12 @@ C<scalar reverse()> reverses by character rather than by byte. =item * The bit string operators, C<& | ^ ~> and (starting in v5.22) -C<&. |. ^. ~.> can operate on characters that don't fit into a byte. -However, the current behavior is likely to change. You should not use -these operators on strings that are encoded in UTF-8. If you're not -sure about the encoding of a string, downgrade it before using any of -these operators; you can use +C<&. |. ^. ~.> can operate on bit strings encoded in UTF-8, but this +can give unexpected results if any of the strings contain code points +above 0xFF. Starting in v5.28, it is a fatal error to have such an +operand. Otherwise, the operation is performed on a non-UTF-8 copy of +the operand. If you're not sure about the encoding of a string, +downgrade it before using any of these operators; you can use L<C<utf8::utf8_downgrade()>|utf8/Utility functions>. =back diff --git a/pod/perluniintro.pod b/pod/perluniintro.pod index 3e2fba516f..73aadff7e0 100644 --- a/pod/perluniintro.pod +++ b/pod/perluniintro.pod @@ -534,15 +534,17 @@ you want to see what the native values are.) =item * -Bit Complement Operator ~ And vec() +Starting in Perl 5.28, it is illegal for bit operators, like C<~>, to +operate on strings containing code points above 255. -The bit complement operator C<~> may produce surprising results if +=item * + +The vec() function may produce surprising results if used on strings containing characters with ordinal values above 255. In such a case, the results are consistent with the internal encoding of the characters, but not with much else. So don't do -that. Similarly for C<vec()>: you will be operating on the -internally-encoded bit patterns of the Unicode characters, not on -the code point values, which is very probably not what you want. +that, and starting in Perl 5.28, a deprecation message is issued if you +do so, becoming illegal in Perl 5.32. =item * diff --git a/pp.c b/pp.c index 0bb1d61e71..305792f67b 100644 --- a/pp.c +++ b/pp.c @@ -2635,43 +2635,17 @@ S_scomplement(pTHX_ SV *targ, SV *sv) sv_copypv_nomg(TARG, sv); tmps = (U8*)SvPV_nomg(TARG, len); - anum = len; + if (SvUTF8(TARG)) { - /* Calculate exact length, let's not estimate. */ - STRLEN targlen = 0; - STRLEN l; - UV nchar = 0; - U8 * const send = tmps + len; - U8 * const origtmps = tmps; - const UV utf8flags = UTF8_ALLOW_ANYUV; - U8 *result; - U8 *p; - - while (tmps < send) { - const UV c = utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags); - tmps += l; - targlen += UVCHR_SKIP(~c); - nchar++; - if (c > 0xff) - Perl_croak(aTHX_ - fatal_above_ff_msg, PL_op_desc[PL_op->op_type]); - } + if (len && ! utf8_to_bytes(tmps, &len)) { + Perl_croak(aTHX_ fatal_above_ff_msg, PL_op_desc[PL_op->op_type]); + } + SvCUR(TARG) = len; + SvUTF8_off(TARG); + } + + anum = len; - /* Now rewind strings and write them. */ - tmps = origtmps; - - Newx(result, nchar + 1, U8); - p = result; - while (tmps < send) { - const U8 c = (U8)utf8n_to_uvchr(tmps, send-tmps, &l, utf8flags); - tmps += l; - *p++ = ~c; - } - *p = '\0'; - sv_usepvn_flags(TARG, (char*)result, nchar, SV_HAS_TRAILING_NUL); - SvUTF8_off(TARG); - return; - } #ifdef LIBERAL { long *tmpl; diff --git a/t/op/bop.t b/t/op/bop.t index 45ebb00e3b..541d671b69 100644 --- a/t/op/bop.t +++ b/t/op/bop.t @@ -5,7 +5,6 @@ # use warnings; -no warnings 'deprecated'; BEGIN { chdir 't' if -d 't'; @@ -19,7 +18,7 @@ BEGIN { # If you find tests are failing, please try adding names to tests to track # down where the failure is, and supply your new names as a patch. # (Just-in-time test naming) -plan tests => 334; +plan tests => 471; # numerics ok ((0xdead & 0xbeef) == 0x9ead); @@ -267,6 +266,28 @@ $a = "\0\x{100}"; chop($a); ok(utf8::is_utf8($a)); # make sure UTF8 flag is still there $a = ~$a; is($a, "\xFF", "~ works with utf-8"); +ok(! utf8::is_utf8($a), " and turns off the UTF-8 flag"); + +$a = "\0\x{100}"; chop($a); +undef $b; +$b = $a | "\xFF"; +ok(utf8::is_utf8($b), "Verify UTF-8 | non-UTF-8 retains UTF-8 flag"); +undef $b; +$b = "\xFF" | $a; +ok(utf8::is_utf8($b), "Verify non-UTF-8 | UTF-8 retains UTF-8 flag"); +undef $b; +$b = $a & "\xFF"; +ok(utf8::is_utf8($b), "Verify UTF-8 & non-UTF-8 retains UTF-8 flag"); +undef $b; +$b = "\xFF" & $a; +ok(utf8::is_utf8($b), "Verify non-UTF-8 & UTF-8 retains UTF-8 flag"); +undef $b; +$b = $a ^ "\xFF"; +ok(utf8::is_utf8($b), "Verify UTF-8 ^ non-UTF-8 retains UTF-8 flag"); +undef $b; +$b = "\xFF" ^ $a; +ok(utf8::is_utf8($b), "Verify non-UTF-8 ^ UTF-8 retains UTF-8 flag"); + # [rt.perl.org 33003] # This would cause a segfault without malloc wrap @@ -281,12 +302,12 @@ SKIP: { $a &= "a"; ok($a =~ /a+$/, 'ASCII "a" is NUL-terminated'); - $b = "bb\x{100}"; + $b = "bb\x{FF}"; + utf8::upgrade($b); $b &= "b"; ok($b =~ /b+$/, 'Unicode "b" is NUL-terminated'); } - # New string- and number-specific bitwise ops { use feature "bitwise"; @@ -339,7 +360,8 @@ SKIP: { my %res; -for my $str ("x", "\x{100}") { +for my $str ("x", "\x{B6}") { + utf8::upgrade($str) if $str !~ /x/; for my $chr (qw/S A H G X ( * F/) { for my $op (qw/| & ^/) { my $co = ord $chr; @@ -379,8 +401,9 @@ for ( ) { my ($val, $orig, $type) = @$_; - for (["x", "string"]) { + for (["x", "string"], ["\x{B6}", "utf8"]) { my ($str, $desc) = @$_; + utf8::upgrade($str) if $desc =~ /utf8/; $warn = 0; -- Perl5 Master Repository
