This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Give up on through.t on VMS for now -- no can do with current
[perl5.git] / t / io / through.t
CommitLineData
93c2c2ec
IZ
1#!./perl
2
3BEGIN {
0af9e257
CB
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 }
93c2c2ec
IZ
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 = '';
1031ca5c
SP
41$set_out = "binmode STDOUT, ':crlf'"
42 if defined $main::use_crlf && $main::use_crlf == 1;
93c2c2ec
IZ
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 }
1031ca5c
SP
84 binmode $fh, ':crlf'
85 if defined $main::use_crlf && $main::use_crlf == 1;
93c2c2ec
IZ
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;
1031ca5c
SP
95 binmode $fh, ':crlf'
96 if defined $main::use_crlf && $main::use_crlf == 1;
93c2c2ec
IZ
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;
1031ca5c
SP
110 binmode $fh, ':crlf'
111 if defined $main::use_crlf && $main::use_crlf == 1;
93c2c2ec
IZ
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');
1031ca5c
SP
120$c = undef;
121my @c;
93c2c2ec
IZ
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;