t/io/through.t

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