| 1 | #!./perl |
| 2 | |
| 3 | BEGIN { |
| 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 | |
| 12 | use strict; |
| 13 | require './test.pl'; |
| 14 | |
| 15 | my $Perl = which_perl(); |
| 16 | |
| 17 | my $data = <<'EOD'; |
| 18 | x |
| 19 | yy |
| 20 | z |
| 21 | EOD |
| 22 | |
| 23 | (my $data2 = $data) =~ s/\n/\n\n/g; |
| 24 | |
| 25 | my $t1 = { data => $data, write_c => [1,2,length $data], read_c => [1,2,3,length $data]}; |
| 26 | my $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 | |
| 32 | my $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 | |
| 38 | print "1..$c\n"; |
| 39 | |
| 40 | my $set_out = ''; |
| 41 | $set_out = "binmode STDOUT, ':crlf'" |
| 42 | if defined $main::use_crlf && $main::use_crlf == 1; |
| 43 | |
| 44 | sub 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 | |
| 68 | sub 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 | |
| 89 | sub 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 | my $filename = tempfile(); |
| 94 | open my $fh, '>', $filename or die; |
| 95 | select $fh; |
| 96 | binmode $fh, ':crlf' |
| 97 | if defined $main::use_crlf && $main::use_crlf == 1; |
| 98 | if ($how_w eq 'print') { # AUTOFLUSH??? |
| 99 | $| = 0; |
| 100 | print $fh $_ for @data; |
| 101 | } elsif ($how_w eq 'print/flush') { |
| 102 | $| = 1; |
| 103 | print $fh $_ for @data; |
| 104 | } elsif ($how_w eq 'syswrite') { |
| 105 | syswrite $fh, $_ for @data; |
| 106 | } else { |
| 107 | die "Unrecognized write: '$how_w'"; |
| 108 | } |
| 109 | close $fh or die "close: $!"; |
| 110 | open $fh, '<', $filename or die; |
| 111 | binmode $fh, ':crlf' |
| 112 | if defined $main::use_crlf && $main::use_crlf == 1; |
| 113 | testread($fh, $str, $read_c, $how_r, $write_c, $how_w, "file$why"); |
| 114 | } |
| 115 | |
| 116 | # shell-neutral and miniperl-enabled autoflush? qq(\x24\x7c) eq '$|' |
| 117 | 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: $!"; |
| 118 | ok(1, 'open pipe'); |
| 119 | binmode $fh, q(:crlf); |
| 120 | ok(1, 'binmode'); |
| 121 | $c = undef; |
| 122 | my @c; |
| 123 | push @c, ord $c while $c = getc $fh; |
| 124 | ok(1, 'got chars'); |
| 125 | is(scalar @c, 9, 'got 9 chars'); |
| 126 | is("@c", '97 10 98 10 10 99 10 10 10', 'got expected chars'); |
| 127 | ok(close($fh), 'close'); |
| 128 | |
| 129 | for my $s (1..2) { |
| 130 | my $t = ($t1, $t2)[$s-1]; |
| 131 | my $str = $t->{data}; |
| 132 | my $r = $t->{read_c}; |
| 133 | my $w = $t->{write_c}; |
| 134 | for my $read_c (@$r) { |
| 135 | for my $write_c (@$w) { |
| 136 | for my $how_r (qw(readline_all readline read sysread)) { |
| 137 | next if $how_r eq 'readline_all' and $read_c != 1; |
| 138 | for my $how_w (qw(print print/flush syswrite)) { |
| 139 | testfile($str, $write_c, $read_c, $how_w, $how_r, $s); |
| 140 | testpipe($str, $write_c, $read_c, $how_w, $how_r, $s); |
| 141 | } |
| 142 | } |
| 143 | } |
| 144 | } |
| 145 | } |
| 146 | |
| 147 | 1; |