In perl.git, the branch blead has been updated <https://perl5.git.perl.org/perl.git/commitdiff/fd879d933c2a2ee22ac6e2462acc016aa033854d?hp=56e36cbf2fdf9d90f61690c1c3fc35af0d65e0cd>
- Log ----------------------------------------------------------------- commit fd879d933c2a2ee22ac6e2462acc016aa033854d Author: Karl Williamson <[email protected]> Date: Sun Jul 1 22:39:47 2018 -0600 PATCH: [perl #131642] pack returning malformed UTF-8 This patch causes pack to die rather than return malformed UTF-8. This protects the rest of the core from unexpectedly getting malformed inputs. ----------------------------------------------------------------------- Summary of changes: pp_pack.c | 15 +++++++++++++++ t/lib/warnings/utf8 | 3 ++- t/op/pack.t | 14 +++++--------- 3 files changed, 22 insertions(+), 10 deletions(-) diff --git a/pp_pack.c b/pp_pack.c index 5f1a599eb4..726f7438a3 100644 --- a/pp_pack.c +++ b/pp_pack.c @@ -3149,6 +3149,21 @@ PP(pp_pack) packlist(cat, pat, patend, MARK, SP + 1); + if (SvUTF8(cat)) { + STRLEN result_len; + const char * result = SvPV_nomg(cat, result_len); + const U8 * error_pos; + + if (! is_utf8_string_loc((U8 *) result, result_len, &error_pos)) { + _force_out_malformed_utf8_message(error_pos, + (U8 *) result + result_len, + 0, /* no flags */ + 1 /* Die */ + ); + NOT_REACHED; /* NOTREACHED */ + } + } + SvSETMAGIC(cat); SP = ORIGMARK; PUSHs(cat); diff --git a/t/lib/warnings/utf8 b/t/lib/warnings/utf8 index a9a6388d31..49fa4e404f 100644 --- a/t/lib/warnings/utf8 +++ b/t/lib/warnings/utf8 @@ -782,4 +782,5 @@ use warnings 'utf8'; for(uc 0..t){0~~pack"UXc",exp} EXPECT OPTIONS regex -Malformed UTF-8 character: \\x([[:xdigit:]]{2})\\x([[:xdigit:]]{2}) \(unexpected non-continuation byte 0x\2, immediately after start byte 0x\1; need 2 bytes, got 1\) in smart match at - line 9. +Malformed UTF-8 character: \\x([[:xdigit:]]{2})\\x([[:xdigit:]]{2}) \(unexpected non-continuation byte 0x\2, immediately after start byte 0x\1; need 2 bytes, got 1\) in pack at - line 9. +Malformed UTF-8 character \(fatal\) at - line 9. diff --git a/t/op/pack.t b/t/op/pack.t index bb9f865091..4543cde3f9 100644 --- a/t/op/pack.t +++ b/t/op/pack.t @@ -955,15 +955,11 @@ is("@{[unpack('U*', pack('U*', 100, 200))]}", "100 200"); is("@{[pack('C0U*', map { utf8::native_to_unicode($_) } 64, 202)]}", pack("C*", 64, @bytes202)); - # does unpack U0U on byte data warn? - { - use warnings qw(NONFATAL all);; - - my $bad = pack("U0C", 202); - local $SIG{__WARN__} = sub { $@ = "@_" }; - my @null = unpack('U0U', $bad); - like($@, qr/^Malformed UTF-8 character: /); - } + # does unpack U0U on byte data fail? + fresh_perl_like('my $bad = pack("U0C", 202); my @null = unpack("U0U", $bad);', + qr/^Malformed UTF-8 character: /, + {}, + "pack doesn't return malformed UTF-8"); } { -- Perl5 Master Repository
