develooper Front page | perl.perl5.changes | Postings from March 2019

[perl.git] branch blead updated. v5.29.8-60-gfd879d933c

From:
Karl Williamson
Date:
March 8, 2019 19:41
Subject:
[perl.git] branch blead updated. v5.29.8-60-gfd879d933c
Message ID:
E1h2LMh-0005Pl-Fe@git.dc.perl.space
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 <khw@cpan.org>
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



nntp.perl.org: Perl Programming lists via nntp and http.
Comments to Ask Bjørn Hansen at ask@perl.org | Group listing | About