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