Change 34129 by [EMAIL PROTECTED] on 2008/07/11 20:04:57
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.
Affected files ...
... //depot/perl/pp_ctl.c#696 edit
... //depot/perl/t/op/write.t#50 edit
Differences ...
==== //depot/perl/pp_ctl.c#696 (text) ====
Index: perl/pp_ctl.c
--- perl/pp_ctl.c#695~34125~ 2008-07-11 04:20:04.000000000 -0700
+++ perl/pp_ctl.c 2008-07-11 13:04:57.000000000 -0700
@@ -503,6 +503,7 @@
*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 @@
{
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 @@
}
}
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 @@
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;
}
==== //depot/perl/t/op/write.t#50 (xtext) ====
Index: perl/t/op/write.t
--- perl/t/op/write.t#49~34124~ 2008-07-11 03:44:51.000000000 -0700
+++ perl/t/op/write.t 2008-07-11 13:04:57.000000000 -0700
@@ -61,7 +61,7 @@
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 @@
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 =
.
End of Patch.
