t/io/through.t

   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   open my $fh, '>', 'io_io.tmp' or die;
  94   select $fh;
  95   binmode $fh, ':crlf'
  96       if defined $main::use_crlf && $main::use_crlf == 1;
  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;
 110   binmode $fh, ':crlf'
 111       if defined $main::use_crlf && $main::use_crlf == 1;
 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 '$|'
 116 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: $!";
 117 ok(1, 'open pipe');
 118 binmode $fh, q(:crlf);
 119 ok(1, 'binmode');
 120 $c = undef;
 121 my @c;
 122 push @c, ord $c while $c = getc $fh;
 123 ok(1, 'got chars');
 124 is(scalar @c, 9, 'got 9 chars');
 125 is("@c", '97 10 98 10 10 99 10 10 10', 'got expected chars');
 126 ok(close($fh), 'close');
 127
 128 for 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
 146 unlink 'io_io.tmp';
 147
 148 1;