Change 34270 by [EMAIL PROTECTED] on 2008/09/05 12:56:09
Integrate:
[ 34139]
For cases FF_LINESNGL and FF_LINEGLOB in pp_formline, take great care
to call get magic exactly once. This doesn't just avoid logical errors
with tied variables, it actually avoids panics (or worse) because a
pointer is retained to the string returned by the (first) call to
SvPV_const() for a future sv_chop(), and any future call to get magic
can invalidate the buffer that that pointer points to.
Also this removes the original crazy code that would set then reset the
length of a scalar, so as to only copy an initial portion of it, and
also copy the entire scalar including trailing newline (which might
require allocating more memory), only to immediately remove the newline
from the copy by reducing the length by one.
[ 34140]
Make format items @* and ^* work with references (safely). Note no-one
said anything about sanely.
Affected files ...
... //depot/maint-5.10/perl/pp_ctl.c#20 integrate
... //depot/maint-5.10/perl/t/op/write.t#4 integrate
Differences ...
==== //depot/maint-5.10/perl/pp_ctl.c#20 (text) ====
Index: perl/pp_ctl.c
--- perl/pp_ctl.c#19~34268~ 2008-09-05 03:06:01.000000000 -0700
+++ perl/pp_ctl.c 2008-09-05 05:56:09.000000000 -0700
@@ -762,39 +762,68 @@
item_is_utf8 = DO_UTF8(sv);
itemsize = len;
if (itemsize) {
- bool chopped = FALSE;
+ STRLEN to_copy = itemsize;
const char *const send = s + len;
+ const U8 *source = (const U8 *) s;
+ U8 *tmp = NULL;
+
gotsome = TRUE;
chophere = s + itemsize;
while (s < send) {
if (*s++ == '\n') {
if (oneline) {
- chopped = TRUE;
+ to_copy = s - SvPVX_const(sv) - 1;
chophere = s;
break;
} else {
if (s == send) {
itemsize--;
- chopped = TRUE;
+ to_copy--;
} else
lines++;
}
}
}
- SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
- if (oneline) {
- SvCUR_set(sv, chophere - item);
- sv_catsv(PL_formtarget, sv);
- SvCUR_set(sv, itemsize);
- } else
- sv_catsv(PL_formtarget, sv);
- if (chopped)
- SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) - 1);
- SvGROW(PL_formtarget, SvCUR(PL_formtarget) + fudge + 1);
+ if (targ_is_utf8 && !item_is_utf8) {
+ source = tmp = bytes_to_utf8(source, &to_copy);
+ SvCUR_set(PL_formtarget,
+ t - SvPVX_const(PL_formtarget));
+ } else {
+ if (item_is_utf8 && !targ_is_utf8) {
+ /* Upgrade targ to UTF8, and then we reduce it to
+ a problem we have a simple solution for. */
+ SvCUR_set(PL_formtarget,
+ t - SvPVX_const(PL_formtarget));
+ targ_is_utf8 = TRUE;
+ /* Don't need get magic. */
+ sv_utf8_upgrade_flags(PL_formtarget, 0);
+ } else {
+ SvCUR_set(PL_formtarget,
+ t - SvPVX_const(PL_formtarget));
+ }
+
+ /* Easy. They agree. */
+ assert (item_is_utf8 == targ_is_utf8);
+ }
+ SvGROW(PL_formtarget,
+ SvCUR(PL_formtarget) + to_copy + fudge + 1);
t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
+
+ Copy(source, t, to_copy, char);
+ t += to_copy;
+ SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
if (item_is_utf8) {
- targ_is_utf8 = TRUE;
- sv_pos_b2u(sv, &itemsize);
+ if (SvGMAGICAL(sv)) {
+ /* Mustn't call sv_pos_b2u() as it does a second
+ mg_get(). Is this a bug? Do we need a _flags()
+ variant? */
+ itemsize = utf8_length(source, source + itemsize);
+ } else {
+ sv_pos_b2u(sv, &itemsize);
+ }
+ assert(!tmp);
+ } else if (tmp) {
+ Safefree(tmp);
}
}
break;
==== //depot/maint-5.10/perl/t/op/write.t#4 (xtext) ====
Index: perl/t/op/write.t
--- perl/t/op/write.t#3~34268~ 2008-09-05 03:06:01.000000000 -0700
+++ perl/t/op/write.t 2008-09-05 05:56:09.000000000 -0700
@@ -61,7 +61,7 @@
my $bas_tests = 20;
# number of tests in section 3
-my $bug_tests = 4 + 3 * 3 * 5 * 2;
+my $bug_tests = 4 + 3 * 3 * 5 * 2 * 3 + 2;
# number of tests in section 4
my $hmb_tests = 35;
@@ -512,7 +512,28 @@
}
{
- my ($pound_utf8, $pm_utf8) = map { my $a = "$_\x{100}"; chop $a; $a}
+ package Count;
+
+ sub TIESCALAR {
+ my $class = shift;
+ bless [shift, 0, 0], $class;
+ }
+
+ sub FETCH {
+ my $self = shift;
+ ++$self->[1];
+ $self->[0];
+ }
+
+ sub STORE {
+ my $self = shift;
+ ++$self->[2];
+ $self->[0] = shift;
+ }
+}
+
+{
+ 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) {
@@ -521,22 +542,42 @@
"$base\nMoo!\n",) {
foreach (['^*', qr/(.+)/], ['@*', qr/(.*?)$/s]) {
my ($format, $re) = @$_;
- my $name = "$first, $second $format";
- $name =~ s/\n/\\n/g;
-
- my ($copy1, $copy2) = ($first, $second);
- $first =~ /(.+)/ or die $first;
- my $expect = "1${1}2";
- $second =~ $re or die $second;
- $expect .= " 3${1}4";
-
- is swrite("1^*2 3${format}4", $copy1, $copy2), $expect, $name;
+ foreach my $class ('', 'Count') {
+ my $name = "$first, $second $format $class";
+ $name =~ s/\n/\\n/g;
+
+ $first =~ /(.+)/ or die $first;
+ my $expect = "1${1}2";
+ $second =~ $re or die $second;
+ $expect .= " 3${1}4";
+
+ if ($class) {
+ my $copy1 = $first;
+ my $copy2;
+ tie $copy2, $class, $second;
+ is swrite("1^*2 3${format}4", $copy1, $copy2), $expect, $name;
+ my $obj = tied $copy2;
+ is $obj->[1], 1, 'value read exactly once';
+ } else {
+ my ($copy1, $copy2) = ($first, $second);
+ is swrite("1^*2 3${format}4", $copy1, $copy2), $expect, $name;
+ }
+ }
}
}
}
}
}
+{
+ # This will fail an assertion in 5.10.0 built with -DDEBUGGING (because
+ # pp_formline attempts to set SvCUR() on an SVt_RV). I suspect that it will
+ # be doing something similarly out of bounds on everything from 5.000
+ my $ref = [];
+ is swrite('>^*<', $ref), ">$ref<";
+ is swrite('>@*<', $ref), ">$ref<";
+}
+
format EMPTY =
.
End of Patch.
