Regression tests for, and fix quite a lot of bugs in, cases FF_LINESNGL

and FF_LINEGLOB in pp_formline. (While investigating RT #55668)
Sometimes I wonder if this is actually fun.

p4raw-id: //depot/perl@34129

diff --git a/pp_ctl.c b/pp_ctl.c
index 3c6ab23..6a0c804 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -503,6 +503,7 @@ PP(pp_formline)
                *t = '\0';
                sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
                t = SvEND(PL_formtarget);
+               f += arg;
                break;
            }
            if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
@@ -767,9 +768,8 @@ PP(pp_formline)
            {
                const bool oneline = fpc[-1] == FF_LINESNGL;
                const char *s = item = SvPV_const(sv, len);
+               item_is_utf8 = DO_UTF8(sv);
                itemsize = len;
-               if ((item_is_utf8 = DO_UTF8(sv)))
-                   itemsize = sv_len_utf8(sv);
                if (itemsize) {
                    bool chopped = FALSE;
                    const char *const send = s + len;
@@ -791,8 +791,6 @@ PP(pp_formline)
                        }
                    }
                    SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
-                   if (targ_is_utf8)
-                       SvUTF8_on(PL_formtarget);
                    if (oneline) {
                        SvCUR_set(sv, chophere - item);
                        sv_catsv(PL_formtarget, sv);
@@ -803,8 +801,10 @@ PP(pp_formline)
                        SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
                    SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
                    t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
-                   if (item_is_utf8)
+                   if (item_is_utf8) {
                        targ_is_utf8 = TRUE;
+                       sv_pos_b2u(sv, &itemsize);
+                   }
                }
                break;
            }

diff --git a/t/op/write.t b/t/op/write.t
index 853b129..89b5beb 100755 (executable)
--- a/t/op/write.t
+++ b/t/op/write.t
@@ -61,7 +61,7 @@ for my $tref ( @NumTests ){
 my $bas_tests = 20;
 
 # number of tests in section 3
-my $bug_tests = 4;
+my $bug_tests = 4 + 3 * 3 * 3;
 
 # number of tests in section 4
 my $hmb_tests = 35;
@@ -511,6 +511,27 @@ for my $tref ( @NumTests ){
     like $@, qr/Undefined format/, 'no such format';
 }
 
+{
+  my ($pound_utf8, $pm_utf8) = map { my $a = "$_\x{100}"; chop $a; $a} 
+    my ($pound, $pm) = ("\xA3", "\xB1");
+
+  foreach my $first ('N', $pound, $pound_utf8) {
+    foreach my $base ('N', $pm, $pm_utf8) {
+      foreach my $second ($base, "$base\n", "$base\nMoo!") {
+       my $name = "$first, $second";
+       $name =~ s/\n/\\n/;
+
+       my ($copy1, $copy2) = ($first, $second);
+       $first =~ /(.+)/ or die $first;
+       my $expect = "1${1}2";
+       $second =~ /(.+)/ or die $second;
+       $expect .= " 3${1}4";
+
+       is swrite('1^*2 3^*4', $copy1, $copy2), $expect, $name;
+      }
+    }
+  }
+}
 
 format EMPTY =
 .