From c56ed9f6dbe3d89129c7f5a37b28d4fc398561e4 Mon Sep 17 00:00:00 2001 From: Father Chrysostomos Date: Sat, 3 Aug 2013 23:58:56 -0700 Subject: [PATCH] [perl #119043] Allow utf8 up/downgrade on ro COWs MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit Commit 1913067 allowed COW constants to be read-only. This broke Glib, so I reverted it with ba36554e02. That caused this bug to reë- merge (I hadn’t realised that I had fixed it in 1913067): perl -e 'for(1..10){for(__PACKAGE__){warn $_; $_++}}' main at -e line 1. maio at -e line 1. maip at -e line 1. maiq at -e line 1. mair at -e line 1. so I reverted the revert two commits ago. Glib was triggering a read-only error because it called sv_utf8_upgrade on a read-only COW scalar, and sv_utf8_upgrade does sv_force_normal on COWs to de-COW them. sv_force_normal croaks on read-only scalars. The real problem here is that sv_force_normal means ‘I am going to modify this scalar’, yet sv_utf8_upgrade conceptually does not modify the scalar, but only changes the internal representation. Having to call sv_force_normal to get the *side effect* of de-COWing without triggering the various other things it does is no good. What we need is a separate sv_uncow function that sv_force_normal uses. This commit introduces such a function. --- lib/utf8.t | 25 +++++++++++++++++++++++++ sv.c | 37 ++++++++++++++++++++----------------- 2 files changed, 45 insertions(+), 17 deletions(-) diff --git a/lib/utf8.t b/lib/utf8.t index 8e2b8ea..e6c94e6 100644 --- a/lib/utf8.t +++ b/lib/utf8.t @@ -563,4 +563,29 @@ for my $pos (0..5) { is($s, "A\xc8\x81\xe8\xab\x86","(pos $pos) str after U; utf8::encode"); } +# [perl #119043] utf8::upgrade should not croak on read-only COWs +for(__PACKAGE__) { + # First make sure we have a COW, otherwise this test is useless. + my $copy = $_; + my @addrs = unpack "L!L!", pack "pp", $copy, $_; + if ($addrs[0] != $addrs[1]) { + fail("__PACKAGE__ did not produce a COW - if this change was " + ."intentional, please provide me with another ro COW scalar") + } + else { + eval { utf8::upgrade($_) }; + is $@, "", 'no error with utf8::upgrade on read-only COW'; + } +} +# This one croaks, but not because the scalar is read-only +eval "package \x{100};\n" . <<'END' + for(__PACKAGE__) { + eval { utf8::downgrade($_) }; + ::like $@, qr/^Wide character/, + 'right error with utf8::downgrade on read-only COW'; + } + 1 +END +or die $@; + done_testing(); diff --git a/sv.c b/sv.c index 43488a2..fcc0761 100644 --- a/sv.c +++ b/sv.c @@ -3223,6 +3223,8 @@ especially if it could return the position of the first one. */ +static void S_sv_uncow(pTHX_ SV * const sv, const U32 flags); + STRLEN Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extra) { @@ -3251,7 +3253,7 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extr } if (SvIsCOW(sv)) { - sv_force_normal_flags(sv, 0); + S_sv_uncow(aTHX_ sv, 0); } if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) { @@ -3510,7 +3512,7 @@ Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok) int mg_flags = SV_GMAGIC; if (SvIsCOW(sv)) { - sv_force_normal_flags(sv, 0); + S_sv_uncow(aTHX_ sv, 0); } if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { /* update pos */ @@ -4871,18 +4873,14 @@ with flags set to 0. =cut */ -void -Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags) +static void +S_sv_uncow(pTHX_ SV * const sv, const U32 flags) { dVAR; - PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS; - + assert(SvIsCOW(sv)); + { #ifdef PERL_ANY_COW - if (SvREADONLY(sv)) { - Perl_croak_no_modify(); - } - else if (SvIsCOW(sv)) { const char * const pvx = SvPVX_const(sv); const STRLEN len = SvLEN(sv); const STRLEN cur = SvCUR(sv); @@ -4935,13 +4933,7 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags) sv_dump(sv); } } - } #else - if (SvREADONLY(sv)) { - Perl_croak_no_modify(); - } - else - if (SvIsCOW(sv)) { const char * const pvx = SvPVX_const(sv); const STRLEN len = SvCUR(sv); SvIsCOW_off(sv); @@ -4956,8 +4948,19 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags) *SvEND(sv) = '\0'; } unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); - } #endif + } +} + +void +Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags) +{ + PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS; + + if (SvREADONLY(sv)) + Perl_croak_no_modify(); + else if (SvIsCOW(sv)) + S_sv_uncow(aTHX_ sv, flags); if (SvROK(sv)) sv_unref_flags(sv, flags); else if (SvFAKE(sv) && isGV_with_GP(sv)) -- 1.8.3.1