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