This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
9c8a627f9ddcc6e60ad1f5b427b68ef4adc0ae67
[perl5.git] / t / io / through.t
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'"
38     if defined  $main::use_crlf && $main::use_crlf == 1;
39
40 sub testread ($$$$$$$) {
41   my ($fh, $str, $read_c, $how_r, $write_c, $how_w, $why) = @_;
42   my $buf = '';
43   if ($how_r eq 'readline_all') {
44     $buf .= $_ while <$fh>;
45   } elsif ($how_r eq 'readline') {
46     $/ = \$read_c;
47     $buf .= $_ while <$fh>;
48   } elsif ($how_r eq 'read') {
49     my($in, $c);
50     $buf .= $in while $c = read($fh, $in, $read_c);
51   } elsif ($how_r eq 'sysread') {
52     my($in, $c);
53     $buf .= $in while $c = sysread($fh, $in, $read_c);
54   } else {
55     die "Unrecognized read: '$how_r'";
56   }
57   close $fh or die "close: $!";
58   # The only contamination allowed is with sysread/prints
59   $buf =~ s/\r\n/\n/g if $how_r eq 'sysread' and $how_w =~ /print/;
60   is(length $buf, length $str, "length with wrc=$write_c, rdc=$read_c, $how_w, $how_r, $why");
61   is($buf, $str, "content with wrc=$write_c, rdc=$read_c, $how_w, $how_r, $why");
62 }
63
64 sub testpipe ($$$$$$) {
65   my ($str, $write_c, $read_c, $how_w, $how_r, $why) = @_;
66   (my $quoted = $str) =~ s/\n/\\n/g;;
67   my $fh;
68   if ($how_w eq 'print') {      # AUTOFLUSH???
69     # Should be shell-neutral:
70     open $fh, '-|', qq[$Perl -we "$set_out;print for grep length, split /(.{1,$write_c})/s, qq($quoted)"] or die "open: $!";
71   } elsif ($how_w eq 'print/flush') {
72     # shell-neutral and miniperl-enabled autoflush? qq(\x24\x7c) eq '$|'
73     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: $!";
74   } elsif ($how_w eq 'syswrite') {
75     ### How to protect \$_
76     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: $!";
77   } else {
78     die "Unrecognized write: '$how_w'";
79   }
80   binmode $fh, ':crlf'
81       if defined $main::use_crlf && $main::use_crlf == 1;
82   testread($fh, $str, $read_c, $how_r, $write_c, $how_w, "pipe$why");
83 }
84
85 sub testfile ($$$$$$) {
86   my ($str, $write_c, $read_c, $how_w, $how_r, $why) = @_;
87   my @data = grep length, split /(.{1,$write_c})/s, $str;
88
89   open my $fh, '>', 'io_io.tmp' or die;
90   select $fh;
91   binmode $fh, ':crlf' 
92       if defined $main::use_crlf && $main::use_crlf == 1;
93   if ($how_w eq 'print') {      # AUTOFLUSH???
94     $| = 0;
95     print $fh $_ for @data;
96   } elsif ($how_w eq 'print/flush') {
97     $| = 1;
98     print $fh $_ for @data;
99   } elsif ($how_w eq 'syswrite') {
100     syswrite $fh, $_ for @data;
101   } else {
102     die "Unrecognized write: '$how_w'";
103   }
104   close $fh or die "close: $!";
105   open $fh, '<', 'io_io.tmp' or die;
106   binmode $fh, ':crlf'
107       if defined $main::use_crlf && $main::use_crlf == 1;
108   testread($fh, $str, $read_c, $how_r, $write_c, $how_w, "file$why");
109 }
110
111 # shell-neutral and miniperl-enabled autoflush? qq(\x24\x7c) eq '$|'
112 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: $!";
113 ok(1, 'open pipe');
114 binmode $fh, q(:crlf);
115 ok(1, 'binmode');
116 $c = undef;
117 my @c;
118 push @c, ord $c while $c = getc $fh;
119 ok(1, 'got chars');
120 is(scalar @c, 9, 'got 9 chars');
121 is("@c", '97 10 98 10 10 99 10 10 10', 'got expected chars');
122 ok(close($fh), 'close');
123
124 for my $s (1..2) {
125   my $t = ($t1, $t2)[$s-1];
126   my $str = $t->{data};
127   my $r = $t->{read_c};
128   my $w = $t->{write_c};
129   for my $read_c (@$r) {
130     for my $write_c (@$w) {
131       for my $how_r (qw(readline_all readline read sysread)) {
132         next if $how_r eq 'readline_all' and $read_c != 1;
133         for my $how_w (qw(print print/flush syswrite)) {
134           testfile($str, $write_c, $read_c, $how_w, $how_r, $s);
135           testpipe($str, $write_c, $read_c, $how_w, $how_r, $s);
136         }
137       }
138     }
139   }
140 }
141
142 unlink 'io_io.tmp';
143
144 1;