One part of pp_pack couldn't correctly handle surprises from UTF-8

overloading.

p4raw-id: //depot/perl@28030

diff --git a/pp_pack.c b/pp_pack.c
index 97e22fd..6e11eb2 100644 (file)
--- a/pp_pack.c
+++ b/pp_pack.c
@@ -2544,9 +2544,20 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist )
            if (strchr("aAZ", lookahead.code)) {
                if (lookahead.howlen == e_number) count = lookahead.length;
                else {
-                   if (items > 0)
+                   if (items > 0) {
+                       if (SvGAMAGIC(*beglist)) {
+                           /* Avoid reading the active data more than once
+                              by copying it to a temporary.  */
+                           STRLEN len;
+                           const char *const pv = SvPV_const(*beglist, len);
+                           SV *const temp = sv_2mortal(newSVpvn(pv, len));
+                           if (SvUTF8(*beglist))
+                               SvUTF8_on(temp);
+                           *beglist = temp;
+                       }
                        count = DO_UTF8(*beglist) ?
                            sv_len_utf8(*beglist) : sv_len(*beglist);
+                   }
                    else count = 0;
                    if (lookahead.code == 'Z') count++;
                }

diff --git a/t/uni/overload.t b/t/uni/overload.t
index ca63b44..68a65e8 100644 (file)
--- a/t/uni/overload.t
+++ b/t/uni/overload.t
@@ -7,7 +7,7 @@ BEGIN {
     }
 }
 
-use Test::More tests => 202;
+use Test::More tests => 208;
 
 package UTF8Toggle;
 use strict;
@@ -254,6 +254,13 @@ foreach my $pieces ($bits, UTF8Toggle->new($bits)) {
     like ($pieces ^ $bits, qr/\A\0+\z/, "something xor itself is zeros");
 }
 
+foreach my $value ("\243", UTF8Toggle->new("\243")) {
+    is (pack ("A/A", $value), pack ("A/A", "\243"),
+       "pack copes with overloading");
+    is (pack ("A/A", $value), pack ("A/A", "\243"));
+    is (pack ("A/A", $value), pack ("A/A", "\243"));
+}
+
 END {
     1 while -f $tmpfile and unlink $tmpfile || die "unlink '$tmpfile': $!";
 }