Commit | Line | Data |
---|---|---|
93c2c2ec IZ |
1 | #!./perl |
2 | ||
3 | BEGIN { | |
4 | chdir 't' if -d 't'; | |
95e2dc41 | 5 | require './test.pl'; |
624c42e2 | 6 | set_up_inc('../lib'); |
95e2dc41 NC |
7 | skip_all("VMS too picky about line endings for record-oriented pipes") |
8 | if $^O eq 'VMS'; | |
93c2c2ec IZ |
9 | } |
10 | ||
11 | use strict; | |
93c2c2ec | 12 | |
e91a8fe5 TC |
13 | ++$|; |
14 | ||
93c2c2ec IZ |
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 | ||
e91a8fe5 TC |
40 | my $set_out = "binmode STDOUT, ':raw'"; |
41 | $set_out = "binmode STDOUT, ':raw:crlf'" | |
1031ca5c | 42 | if defined $main::use_crlf && $main::use_crlf == 1; |
93c2c2ec IZ |
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 '$|' | |
c9e22b5f KW |
77 | if ($::IS_ASCII) { |
78 | 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: $!"; | |
79 | } | |
80 | else { | |
81 | open $fh, '-|', qq[$Perl -we "$set_out;eval qq(\\x5b\\x4f = 1) or die;print for grep length, split /(.{1,$write_c})/s, qq($quoted)"] or die "open: $!"; | |
82 | } | |
93c2c2ec IZ |
83 | } elsif ($how_w eq 'syswrite') { |
84 | ### How to protect \$_ | |
c9e22b5f KW |
85 | if ($::IS_ASCII) { |
86 | 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: $!"; | |
87 | } | |
88 | else { | |
89 | open $fh, '-|', qq[$Perl -we "$set_out;eval qq(sub w {syswrite STDOUT, \\x5B_} 1) or die; w() for grep length, split /(.{1,$write_c})/s, qq($quoted)"] or die "open: $!"; | |
90 | } | |
93c2c2ec IZ |
91 | } else { |
92 | die "Unrecognized write: '$how_w'"; | |
93 | } | |
e91a8fe5 | 94 | binmode $fh; # remove any :utf8 set by PERL_UNICODE |
1031ca5c SP |
95 | binmode $fh, ':crlf' |
96 | if defined $main::use_crlf && $main::use_crlf == 1; | |
93c2c2ec IZ |
97 | testread($fh, $str, $read_c, $how_r, $write_c, $how_w, "pipe$why"); |
98 | } | |
99 | ||
100 | sub testfile ($$$$$$) { | |
101 | my ($str, $write_c, $read_c, $how_w, $how_r, $why) = @_; | |
102 | my @data = grep length, split /(.{1,$write_c})/s, $str; | |
103 | ||
62a28c97 | 104 | my $filename = tempfile(); |
1acc81a5 | 105 | open my $fh, '>', $filename or die "open: > $filename: $!"; |
93c2c2ec | 106 | select $fh; |
e91a8fe5 | 107 | binmode $fh; # remove any :utf8 set by PERL_UNICODE |
1031ca5c SP |
108 | binmode $fh, ':crlf' |
109 | if defined $main::use_crlf && $main::use_crlf == 1; | |
93c2c2ec IZ |
110 | if ($how_w eq 'print') { # AUTOFLUSH??? |
111 | $| = 0; | |
112 | print $fh $_ for @data; | |
113 | } elsif ($how_w eq 'print/flush') { | |
114 | $| = 1; | |
115 | print $fh $_ for @data; | |
116 | } elsif ($how_w eq 'syswrite') { | |
117 | syswrite $fh, $_ for @data; | |
118 | } else { | |
119 | die "Unrecognized write: '$how_w'"; | |
120 | } | |
121 | close $fh or die "close: $!"; | |
1acc81a5 | 122 | open $fh, '<', $filename or die "open: < $filename: $!"; |
e91a8fe5 | 123 | binmode $fh; |
1031ca5c SP |
124 | binmode $fh, ':crlf' |
125 | if defined $main::use_crlf && $main::use_crlf == 1; | |
93c2c2ec IZ |
126 | testread($fh, $str, $read_c, $how_r, $write_c, $how_w, "file$why"); |
127 | } | |
128 | ||
129 | # shell-neutral and miniperl-enabled autoflush? qq(\x24\x7c) eq '$|' | |
c9e22b5f KW |
130 | my $fh; |
131 | if ($::IS_ASCII) { | |
132 | open $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: $!"; | |
133 | } | |
134 | else { | |
135 | open $fh, '-|', qq[$Perl -we "eval qq(\\x5B\\x4f = 1) or die; binmode STDOUT; sleep 1, print for split //, qq(a\nb\n\nc\n\n\n)"] or die "open: $!"; | |
136 | } | |
93c2c2ec IZ |
137 | ok(1, 'open pipe'); |
138 | binmode $fh, q(:crlf); | |
139 | ok(1, 'binmode'); | |
1031ca5c SP |
140 | $c = undef; |
141 | my @c; | |
93c2c2ec IZ |
142 | push @c, ord $c while $c = getc $fh; |
143 | ok(1, 'got chars'); | |
144 | is(scalar @c, 9, 'got 9 chars'); | |
c9e22b5f KW |
145 | is("@c", join(" ", utf8::unicode_to_native(97), |
146 | utf8::unicode_to_native(10), | |
147 | utf8::unicode_to_native(98), | |
148 | utf8::unicode_to_native(10), | |
149 | utf8::unicode_to_native(10), | |
150 | utf8::unicode_to_native(99), | |
151 | utf8::unicode_to_native(10), | |
152 | utf8::unicode_to_native(10), | |
153 | utf8::unicode_to_native(10)), | |
154 | 'got expected chars'); | |
93c2c2ec IZ |
155 | ok(close($fh), 'close'); |
156 | ||
157 | for my $s (1..2) { | |
158 | my $t = ($t1, $t2)[$s-1]; | |
159 | my $str = $t->{data}; | |
160 | my $r = $t->{read_c}; | |
161 | my $w = $t->{write_c}; | |
162 | for my $read_c (@$r) { | |
163 | for my $write_c (@$w) { | |
164 | for my $how_r (qw(readline_all readline read sysread)) { | |
165 | next if $how_r eq 'readline_all' and $read_c != 1; | |
166 | for my $how_w (qw(print print/flush syswrite)) { | |
167 | testfile($str, $write_c, $read_c, $how_w, $how_r, $s); | |
168 | testpipe($str, $write_c, $read_c, $how_w, $how_r, $s); | |
169 | } | |
170 | } | |
171 | } | |
172 | } | |
173 | } | |
174 | ||
93c2c2ec | 175 | 1; |