pp_ctl.c:PP(pp_formline) bugs with wide chars in caret fields

[p5pRT]

Migrated from rt.perl.org#108386 (status was 'stalled')

Searchable as RT108386$

[p5pRT]

From antox@ml.lv

Perl `formline' function (and thus `write') misbehaves when
caret fields are filled with Unicode input. Namely when data
has wide characters, but is not longer than the field width,
then printed data is chopped off incorrectly and also CR symbol
may not have the desired effect.

Below are​:
- samples of such behavior,
- proposed fix,
- script for reproducing.

* SAMPLES *

Some samples follow, where
- `in' is input (to `formline'),
- `fmt' is applied format,
- `out' is output (from $^A),
- `lft' is what is left in input variable.

in​: `0Аあ^Mあ^Mあ0' (8) / [30;d0,90;e3,81,82;0d;e3,81,82;0d;e3,81,82;30] (15)
fmt​: `^<<<'
out​: `0Аあ' (3) / [30;d0,90;e3,81,82] (6)
lft​: `あ^Mあ0' (4) / [e3,81,82;0d;e3,81,82;30] (8)

in​: `あ^Mあ0' (4) / [e3,81,82;0d;e3,81,82;30] (8)
fmt​: `^<<<'
out​: `あ あ' (3) / [e3,81,82;20;e3,81,82] (7) [wrong]
lft​: `あ0' (2) / [e3,81,82;30] (4)

in​: `あ0' (2) / [e3,81,82;30] (4)
fmt​: `^<<<'
out​: `あ0' (2) / [e3,81,82;30] (4)
lft​: `\x820' (2) / [82;30] (2) [wrong]

Two lines marked with [wrong] expected to be, respectively​:
out​: `あ' (1) / [e3,81,82] (3)
lft​: `' (0) / [] (0)

(See SCRIPT below for Perl code used to obtain these data.)

* PROPOSED FIX *

This wrong behavior is related to
- file `pp_ctl.c',
- function `PP(pp_formline)',
- `case FF_CHECKCHOP​:',
- Unicode branch with `itemsize <= fieldsize',
where no chars<->bytes transition is performed.

The following patch can be applied​:

--- old/perl-5.14.2/pp_ctl.c
+++ new/perl-5.14.2/pp_ctl.c
@​@​ -705,10 +705,11 @​@​
  if (itemsize != (I32)len) {
  I32 itembytes;
  if (itemsize <= fieldsize) {
- const char *send = chophere = s + itemsize;
+ const char *send = chophere = s + len;
  while (s < send) {
  if (*s == '\r') {
  itemsize = s - item;
+ sv_pos_b2u(sv, &itemsize);
  chophere = s;
  break;
  }

With this patch `perl' compiled from sources (using default
options) produces output as expected. Existing `op/write.t'
tests are still passed.

Without applying the patch, as a workaround, users might append
sufficient amount of space characters to their input.

It turns out that this problem was already touched by Nicolas
Clark​: https://rt-archive.perl.org/perl5/Public/Bug/Display.html?id=56834

This still does not make `$​:' Unicode-aware​:
`strchr(PL_chopset, *s)'
persists and chopping is ruled by separate bytes.

* SCRIPT *

Script used to produce data in SAMPLES above​:

#!/usr/bin/perl

use strict;
use warnings;

binmode STDOUT, "​:encoding(UTF-8)";

test_string('^<<<', "0\x{410}\x{3042}\r\x{3042}\r\x{3042}0");
test_string('^<<<', "\x{3042}\r\x{3042}0");
test_string('^<<<', "\x{3042}0");

sub test_string {
  my ($format, $string) = @​_;
  local $^A = '';
  print 'in​: ', examine_string($string), "\n";
  print "fmt​: `$format'\n";
  formline $format, $string;
  print 'out​: ', examine_string($^A), "\n";
  print 'lft​: ', examine_string($string), "\n";
  print "\n";
}

sub examine_string {
  my $chars = shift;
  my $chars_count = length($chars),
  my @​bytes = ();
  my $bytes_count = 0;
  for (split '', $chars) {
  my @​b = unpack 'U0C*';
  push @​bytes, sprintf('%*v02x', ',', pack 'C*', @​b);
  $bytes_count += @​b;
  }
  local $" = ';';
  "`$chars' ($chars_count) / [@​bytes] ($bytes_count)";
}

Perl Info

Flags:
    category=core
    severity=low

Site configuration information for perl 5.14.2:

Configured by nobody at Tue Jan  3 21:04:36 UTC 2012.

Summary of my perl5 (revision 5 version 14 subversion 2) configuration:
   
  Platform:
    osname=linux, osvers=3.1.6-1-arch, archname=i686-linux-thread-multi
    uname='linux marin 3.1.6-1-arch #1 smp preempt thu dec 22 09:11:48 cet 2011 i686 intel(r) core(tm) i7 cpu 920 @ 2.67ghz genuineintel gnulinux '
    config_args='-des -Dusethreads -Duseshrplib -Doptimize=-march=i686 -mtune=generic -O2 -pipe -fstack-protector --param=ssp-buffer-size=4 -D_FORTIFY_SOURCE=2 -Dprefix=/usr -Dinstallprefix=/usr -Dvendorprefix=/usr -Dprivlib=/usr/share/perl5/core_perl -Darchlib=/usr/lib/perl5/core_perl -Dsitelib=/usr/share/perl5/site_perl -Dsitearch=/usr/lib/perl5/site_perl -Dvendorlib=/usr/share/perl5/vendor_perl -Dvendorarch=/usr/lib/perl5/vendor_perl -Dscriptdir=/usr/bin/core_perl -Dsitescript=/usr/bin/site_perl -Dvendorscript=/usr/bin/vendor_perl -Dinc_version_list=none -Dman1ext=1perl -Dman3ext=3perl -Dlddlflags=-shared -Wl,-O1,--sort-common,--as-needed,-z,relro,--hash-style=gnu -Dldflags=-Wl,-O1,--sort-common,--as-needed,-z,relro,--hash-style=gnu'
    hint=recommended, useposix=true, d_sigaction=define
    useithreads=define, usemultiplicity=define
    useperlio=define, d_sfio=undef, uselargefiles=define, usesocks=undef
    use64bitint=undef, use64bitall=undef, uselongdouble=undef
    usemymalloc=n, bincompat5005=undef
  Compiler:
    cc='cc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
    optimize='-march=i686 -mtune=generic -O2 -pipe -fstack-protector --param=ssp-buffer-size=4 -D_FORTIFY_SOURCE=2',
    cppflags='-D_REENTRANT -D_GNU_SOURCE -fno-strict-aliasing -pipe -fstack-protector -I/usr/local/include'
    ccversion='', gccversion='4.6.2 20111223 (prerelease)', gccosandvers=''
    intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234
    d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
    ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
    alignbytes=4, prototype=define
  Linker and Libraries:
    ld='cc', ldflags ='-Wl,-O1,--sort-common,--as-needed,-z,relro,--hash-style=gnu -fstack-protector -L/usr/local/lib'
    libpth=/usr/local/lib /lib /usr/lib
    libs=-lnsl -lgdbm -ldb -ldl -lm -lcrypt -lutil -lpthread -lc -lgdbm_compat
    perllibs=-lnsl -ldl -lm -lcrypt -lutil -lpthread -lc
    libc=/lib/libc-2.15.so, so=so, useshrplib=true, libperl=libperl.so
    gnulibc_version='2.15'
  Dynamic Linking:
    dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E -Wl,-rpath,/usr/lib/perl5/core_perl/CORE'
    cccdlflags='-fPIC', lddlflags='-shared -Wl,-O1,--sort-common,--as-needed,-z,relro,--hash-style=gnu -L/usr/local/lib -fstack-protector'

Locally applied patches:
    


@INC for perl 5.14.2:
    /usr/lib/perl5/site_perl
    /usr/share/perl5/site_perl
    /usr/lib/perl5/vendor_perl
    /usr/share/perl5/vendor_perl
    /usr/lib/perl5/core_perl
    /usr/share/perl5/core_perl
    .


Environment for perl 5.14.2:
    HOME=/home/antox
    LANG=en_US.UTF-8
    LANGUAGE (unset)
    LD_LIBRARY_PATH (unset)
    LOGDIR (unset)
    PATH=/home/antox/bin:/usr/local/bin:/usr/bin:/bin:/usr/local/sbin:/usr/sbin:/sbin:/opt/bin:/usr/share/java/apache-ant/bin:/opt/java/bin:/opt/java/db/bin:/opt/java/jre/bin:/usr/bin/vendor_perl:/usr/bin/core_perl
    PERL_BADLANG (unset)
    SHELL=/bin/zsh

[p5pRT]

From antox@ml.lv

I have discovered another bug in "Perl_pp_formline", "FF_MORE" branch​: ellipsis takes 3 bytes which is wrong when there are wide characters. I include the combined patch (for "FF_CHECHCKOP" and "FF_MORE") and 2 related tests for "t/op/write.t". I am not sure about quality of my code but I hope it is of some help.

The HMB tests produce different results, depending on prior plain "formline" calls (with unpatched "pp_ctl.c" too). I have not figured out what is the reason, and just put a blank "write" after the added tests.

--- old/perl-5.14.2/pp_ctl.c
+++ new/perl-5.14.2/pp_ctl.c
@​@​ -705,10 +705,11 @​@​
  if (itemsize != (I32)len) {
  I32 itembytes;
  if (itemsize <= fieldsize) {
- const char *send = chophere = s + itemsize;
+ const char *send = chophere = s + len;
  while (s < send) {
  if (*s == '\r') {
  itemsize = s - item;
+ sv_pos_b2u(sv, &itemsize);
  chophere = s;
  break;
  }
@​@​ -1044,8 +1045,17 @​@​
  while (arg-- > 0)
  *t++ = ' ';
  }
- s1 = t - 3;
- if (strnEQ(s1," ",3)) {
+ if (item_is_utf8) {
+ for (s1=t, arg=3; arg;) {
+ s1--;
+ if (! UTF8_IS_CONTINUATION(*s1))
+ arg--;
+ *s1 = ' ';
+ }
+ }
+ else
+ s1 = t - 3;
+ if (s1 == t - 3 && strnEQ(s1," ",3)) {
  while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
  s1--;
  }

--- old/perl-5.14.2/t/op/write.t
+++ new/perl-5.14.2/t/op/write.t
@​@​ -61,7 +61,7 @​@​ my $bas_tests = 20;

# number of tests in section 3
-my $bug_tests = 4 + 3 * 3 * 5 * 2 * 3 + 2 + 2 + 1;
+my $bug_tests = 4 + 3 * 3 * 5 * 2 * 3 + 2 + 2 + 1 + 2;

# number of tests in section 4
my $hmb_tests = 35;
@​@​ -639,6 +639,64 @​@​
write;
EOP

+# formline Unicode tests (#108386)​:
+# - chopping in caret-fields;
+# - putting '...' in at-fields.
+{
+my ($format, $output, $expected);
+
+# sample data
+my @​input = split "\n", <<EOD;
+Tokyo - \x{6771}\x{4eac}
+Yokohama - \x{6a2a}\x{6d5c}\x{5e02}
+Osaka - \x{5927}\x{962a}
+Nagoya - \x{540d}\x{53e4}\x{5c4b}
+Sapporo - \x{672d}\x{5e4c}\x{5e02}
+K\x{14d}be - \x{795e}\x{6238}\x{5e02}
+Kyoto - \x{4eac}\x{90fd}\x{5e02}
+EOD
+
+# caret-field test
+$format = <<EOD;
+^<<<<<<<<< ~~
+EOD
+my $input = join "\r", @​input;
+$output = swrite($format, $input);
+$expected = <<EOD;
+Tokyo - \x{6771}\x{4eac}
+Yokohama -
+\x{6a2a}\x{6d5c}\x{5e02}
+Osaka - \x{5927}\x{962a}
+Nagoya -
+\x{540d}\x{53e4}\x{5c4b}
+Sapporo -
+\x{672d}\x{5e4c}\x{5e02}
+K\x{14d}be - \x{795e}\x{6238}\x{5e02}
+Kyoto -
+\x{4eac}\x{90fd}\x{5e02}
+EOD
+is $output, $expected;
+
+# at-field test
+$format = <<EOD;
+@​<<<<<<<<...
+EOD
+$output = join '', map swrite($format, $_), @​input;
+$expected = <<EOD;
+Tokyo - \x{6771}\x{4eac}
+Yokohama ...
+Osaka - \x{5927}\x{962a}
+Nagoya - \x{540d}\x{53e4}\x{5c4b}
+Sapporo -...
+K\x{14d}be - \x{795e}\x{6238}\x{5e02}
+Kyoto - \x{4eac}\x{90fd}\x{5e02}
+EOD
+is $output, $expected;
+}
+
+# XXX​: HMB will fail without some write
+$~ = 'EMPTY'; write;
+
#############################
## Section 4
## Add new tests *above* here

P. S. I am sorry about misspelling Nicholas' name in previous message.

[p5pRT]

@dcollinsn - Status changed from 'new' to 'stalled'