1#!./perl 2 3BEGIN { 4 if ($^O eq 'VMS') { 5 print "1..0 # Skip on VMS -- too picky about line endings for record-oriented pipes\n"; 6 exit; 7 } 8 chdir 't' if -d 't'; 9 @INC = '../lib'; 10} 11 12use strict; 13require './test.pl'; 14 15my $Perl = which_perl(); 16 17my $data = <<'EOD'; 18x 19 yy 20z 21EOD 22 23(my $data2 = $data) =~ s/\n/\n\n/g; 24 25my $t1 = { data => $data, write_c => [1,2,length $data], read_c => [1,2,3,length $data]}; 26my $t2 = { data => $data2, write_c => [1,2,length $data2], read_c => [1,2,3,length $data2]}; 27 28$_->{write_c} = [1..length($_->{data})], 29 $_->{read_c} = [1..length($_->{data})+1, 0xe000] # Need <0xffff for REx 30 for (); # $t1, $t2; 31 32my $c; # len write tests, for each: one _all test, and 3 each len+2 33$c += @{$_->{write_c}} * (1 + 3*@{$_->{read_c}}) for $t1, $t2; 34$c *= 3*2*2; # $how_w, file/pipe, 2 reports 35 36$c += 6; # Tests with sleep()... 37 38print "1..$c\n"; 39 40my $set_out = ''; 41$set_out = "binmode STDOUT, ':crlf'" 42 if defined $main::use_crlf && $main::use_crlf == 1; 43 44sub testread ($$$$$$$) { 45 my ($fh, $str, $read_c, $how_r, $write_c, $how_w, $why) = @_; 46 my $buf = ''; 47 if ($how_r eq 'readline_all') { 48 $buf .= $_ while <$fh>; 49 } elsif ($how_r eq 'readline') { 50 $/ = \$read_c; 51 $buf .= $_ while <$fh>; 52 } elsif ($how_r eq 'read') { 53 my($in, $c); 54 $buf .= $in while $c = read($fh, $in, $read_c); 55 } elsif ($how_r eq 'sysread') { 56 my($in, $c); 57 $buf .= $in while $c = sysread($fh, $in, $read_c); 58 } else { 59 die "Unrecognized read: '$how_r'"; 60 } 61 close $fh or die "close: $!"; 62 # The only contamination allowed is with sysread/prints 63 $buf =~ s/\r\n/\n/g if $how_r eq 'sysread' and $how_w =~ /print/; 64 is(length $buf, length $str, "length with wrc=$write_c, rdc=$read_c, $how_w, $how_r, $why"); 65 is($buf, $str, "content with wrc=$write_c, rdc=$read_c, $how_w, $how_r, $why"); 66} 67 68sub testpipe ($$$$$$) { 69 my ($str, $write_c, $read_c, $how_w, $how_r, $why) = @_; 70 (my $quoted = $str) =~ s/\n/\\n/g;; 71 my $fh; 72 if ($how_w eq 'print') { # AUTOFLUSH??? 73 # Should be shell-neutral: 74 open $fh, '-|', qq[$Perl -we "$set_out;print for grep length, split /(.{1,$write_c})/s, qq($quoted)"] or die "open: $!"; 75 } elsif ($how_w eq 'print/flush') { 76 # shell-neutral and miniperl-enabled autoflush? qq(\x24\x7c) eq '$|' 77 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: $!"; 78 } elsif ($how_w eq 'syswrite') { 79 ### How to protect \$_ 80 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: $!"; 81 } else { 82 die "Unrecognized write: '$how_w'"; 83 } 84 binmode $fh, ':crlf' 85 if defined $main::use_crlf && $main::use_crlf == 1; 86 testread($fh, $str, $read_c, $how_r, $write_c, $how_w, "pipe$why"); 87} 88 89sub testfile ($$$$$$) { 90 my ($str, $write_c, $read_c, $how_w, $how_r, $why) = @_; 91 my @data = grep length, split /(.{1,$write_c})/s, $str; 92 93 open my $fh, '>', 'io_io.tmp' or die; 94 select $fh; 95 binmode $fh, ':crlf' 96 if defined $main::use_crlf && $main::use_crlf == 1; 97 if ($how_w eq 'print') { # AUTOFLUSH??? 98 $| = 0; 99 print $fh $_ for @data; 100 } elsif ($how_w eq 'print/flush') { 101 $| = 1; 102 print $fh $_ for @data; 103 } elsif ($how_w eq 'syswrite') { 104 syswrite $fh, $_ for @data; 105 } else { 106 die "Unrecognized write: '$how_w'"; 107 } 108 close $fh or die "close: $!"; 109 open $fh, '<', 'io_io.tmp' or die; 110 binmode $fh, ':crlf' 111 if defined $main::use_crlf && $main::use_crlf == 1; 112 testread($fh, $str, $read_c, $how_r, $write_c, $how_w, "file$why"); 113} 114 115# shell-neutral and miniperl-enabled autoflush? qq(\x24\x7c) eq '$|' 116open 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: $!"; 117ok(1, 'open pipe'); 118binmode $fh, q(:crlf); 119ok(1, 'binmode'); 120$c = undef; 121my @c; 122push @c, ord $c while $c = getc $fh; 123ok(1, 'got chars'); 124is(scalar @c, 9, 'got 9 chars'); 125is("@c", '97 10 98 10 10 99 10 10 10', 'got expected chars'); 126ok(close($fh), 'close'); 127 128for my $s (1..2) { 129 my $t = ($t1, $t2)[$s-1]; 130 my $str = $t->{data}; 131 my $r = $t->{read_c}; 132 my $w = $t->{write_c}; 133 for my $read_c (@$r) { 134 for my $write_c (@$w) { 135 for my $how_r (qw(readline_all readline read sysread)) { 136 next if $how_r eq 'readline_all' and $read_c != 1; 137 for my $how_w (qw(print print/flush syswrite)) { 138 testfile($str, $write_c, $read_c, $how_w, $how_r, $s); 139 testpipe($str, $write_c, $read_c, $how_w, $how_r, $s); 140 } 141 } 142 } 143 } 144} 145 146unlink 'io_io.tmp'; 147 1481; 149