Re: [BUG 5.8.7] Another major bug in PerlIO layer

Message-ID: <20050927090734.GB3687@math.berkeley.edu>

p4raw-id: //depot/perl@25618

2 files changed, 148 insertions, 0 deletions

diff --git a/t/io/crlf_through.t b/t/io/crlf_through.t
new file mode 100644
index 0000000000..3a5522a76e
--- /dev/null
+++ b/t/io/crlf_through.t
@@ -0,0 +1,9 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+$main::use_crlf = 1;
+do './io/through.t' or die "no kid script";
diff --git a/t/io/through.t b/t/io/through.t
new file mode 100644
index 0000000000..d664b08a18
--- /dev/null
+++ b/t/io/through.t
@@ -0,0 +1,139 @@
+#!./perl
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+use strict;
+require './test.pl';
+
+my $Perl = which_perl();
+
+my $data = <<'EOD';
+x
+ yy
+z
+EOD
+
+(my $data2 = $data) =~ s/\n/\n\n/g;
+
+my $t1 = { data => $data,  write_c => [1,2,length $data],  read_c => [1,2,3,length $data]};
+my $t2 = { data => $data2, write_c => [1,2,length $data2], read_c => [1,2,3,length $data2]};
+
+$_->{write_c} = [1..length($_->{data})],
+  $_->{read_c} = [1..length($_->{data})+1, 0xe000]  # Need <0xffff for REx
+    for (); # $t1, $t2;
+
+my $c;	# len write tests, for each: one _all test, and 3 each len+2
+$c += @{$_->{write_c}} * (1 + 3*@{$_->{read_c}}) for $t1, $t2;
+$c *= 3*2*2;	# $how_w, file/pipe, 2 reports
+
+$c += 6;	# Tests with sleep()...
+
+print "1..$c\n";
+
+my $set_out = '';
+$set_out = "binmode STDOUT, ':crlf'" if $main::use_crlf = 1;
+
+sub testread ($$$$$$$) {
+  my ($fh, $str, $read_c, $how_r, $write_c, $how_w, $why) = @_;
+  my $buf = '';
+  if ($how_r eq 'readline_all') {
+    $buf .= $_ while <$fh>;
+  } elsif ($how_r eq 'readline') {
+    $/ = \$read_c;
+    $buf .= $_ while <$fh>;
+  } elsif ($how_r eq 'read') {
+    my($in, $c);
+    $buf .= $in while $c = read($fh, $in, $read_c);
+  } elsif ($how_r eq 'sysread') {
+    my($in, $c);
+    $buf .= $in while $c = sysread($fh, $in, $read_c);
+  } else {
+    die "Unrecognized read: '$how_r'";
+  }
+  close $fh or die "close: $!";
+  # The only contamination allowed is with sysread/prints
+  $buf =~ s/\r\n/\n/g if $how_r eq 'sysread' and $how_w =~ /print/;
+  is(length $buf, length $str, "length with wrc=$write_c, rdc=$read_c, $how_w, $how_r, $why");
+  is($buf, $str, "content with wrc=$write_c, rdc=$read_c, $how_w, $how_r, $why");
+}
+
+sub testpipe ($$$$$$) {
+  my ($str, $write_c, $read_c, $how_w, $how_r, $why) = @_;
+  (my $quoted = $str) =~ s/\n/\\n/g;;
+  my $fh;
+  if ($how_w eq 'print') {	# AUTOFLUSH???
+    # Should be shell-neutral:
+    open $fh, '-|', qq[$Perl -we "$set_out;print for grep length, split /(.{1,$write_c})/s, qq($quoted)"] or die "open: $!";
+  } elsif ($how_w eq 'print/flush') {
+    # shell-neutral and miniperl-enabled autoflush? qq(\x24\x7c) eq '$|'
+    open $fh, '-|', qq[$Perl -we "$set_out;eval qq(\\x24\\x7c = 1) or die;print for grep length, split /(.{1,$write_c})/s, qq($quoted)"] or die "open: $!";
+  } elsif ($how_w eq 'syswrite') {
+    ### How to protect \$_
+    open $fh, '-|', qq[$Perl -we "$set_out;eval qq(sub w {syswrite STDOUT, \\x24_} 1) or die; w() for grep length, split /(.{1,$write_c})/s, qq($quoted)"] or die "open: $!";
+  } else {
+    die "Unrecognized write: '$how_w'";
+  }
+  binmode $fh, ':crlf' if $main::use_crlf = 1;
+  testread($fh, $str, $read_c, $how_r, $write_c, $how_w, "pipe$why");
+}
+
+sub testfile ($$$$$$) {
+  my ($str, $write_c, $read_c, $how_w, $how_r, $why) = @_;
+  my @data = grep length, split /(.{1,$write_c})/s, $str;
+
+  open my $fh, '>', 'io_io.tmp' or die;
+  select $fh;
+  binmode $fh, ':crlf' if $main::use_crlf = 1;
+  if ($how_w eq 'print') {	# AUTOFLUSH???
+    $| = 0;
+    print $fh $_ for @data;
+  } elsif ($how_w eq 'print/flush') {
+    $| = 1;
+    print $fh $_ for @data;
+  } elsif ($how_w eq 'syswrite') {
+    syswrite $fh, $_ for @data;
+  } else {
+    die "Unrecognized write: '$how_w'";
+  }
+  close $fh or die "close: $!";
+  open $fh, '<', 'io_io.tmp' or die;
+  binmode $fh, ':crlf' if $main::use_crlf = 1;
+  testread($fh, $str, $read_c, $how_r, $write_c, $how_w, "file$why");
+}
+
+# shell-neutral and miniperl-enabled autoflush? qq(\x24\x7c) eq '$|'
+open my $fh, '-|', qq[$Perl -we "eval qq(\\x24\\x7c = 1) or die; binmode STDOUT; sleep 1, print for split //, qq(a\nb\n\nc\n\n\n)"] or die "open: $!";
+ok(1, 'open pipe');
+binmode $fh, q(:crlf);
+ok(1, 'binmode');
+my (@c, $c);
+push @c, ord $c while $c = getc $fh;
+ok(1, 'got chars');
+is(scalar @c, 9, 'got 9 chars');
+is("@c", '97 10 98 10 10 99 10 10 10', 'got expected chars');
+ok(close($fh), 'close');
+
+for my $s (1..2) {
+  my $t = ($t1, $t2)[$s-1];
+  my $str = $t->{data};
+  my $r = $t->{read_c};
+  my $w = $t->{write_c};
+  for my $read_c (@$r) {
+    for my $write_c (@$w) {
+      for my $how_r (qw(readline_all readline read sysread)) {
+	next if $how_r eq 'readline_all' and $read_c != 1;
+        for my $how_w (qw(print print/flush syswrite)) {
+	  testfile($str, $write_c, $read_c, $how_w, $how_r, $s);
+	  testpipe($str, $write_c, $read_c, $how_w, $how_r, $s);
+        }
+      }
+    }
+  }
+}
+
+unlink 'io_io.tmp';
+
+1;