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
|
#!/usr/bin/perl
=pod
=head1 NAME
io.t - Test suite exercising IPC::Run::IO with IPC::Run::run.
=cut
use strict;
use warnings;
BEGIN {
$| = 1;
$^W = 1;
if ( $ENV{PERL_CORE} ) {
chdir '../lib/IPC/Run' if -d '../lib/IPC/Run';
unshift @INC, 'lib', '../..';
$^X = '../../../t/' . $^X;
}
}
use Test::More tests => 14;
use IPC::Run qw( :filters run io );
use IPC::Run::Debug qw( _map_fds );
my $text = "Hello World\n";
my $emitter_script = qq{print '$text'; print STDERR uc( '$text' )};
##
## $^X is the path to the perl binary. This is used run all the subprocesses.
##
my @perl = ($^X);
my @emitter = ( @perl, '-e', $emitter_script );
my $recv;
my $send;
my $in_file = 'io.t.in';
my $out_file = 'io.t.out';
my $err_file = 'io.t.err';
my $io;
my $r;
my $fd_map;
## TODO: Test filters, etc.
sub slurp($) {
my ($f) = @_;
open( S, "<$f" ) or return "$! '$f'";
my $r = join( '', <S> );
close S or warn "$! closing '$f'";
return $r;
}
sub spit($$) {
my ( $f, $s ) = @_;
open( S, ">$f" ) or die "$! '$f'";
print S $s or die "$! '$f'";
close S or die "$! '$f'";
}
sub wipe($) {
my ($f) = @_;
unlink $f or warn "$! unlinking '$f'" if -f $f;
}
$io = io( 'foo', '<', \$send );
ok $io->isa('IPC::Run::IO');
is( io( 'foo', '<', \$send )->mode, 'w' );
is( io( 'foo', '<<', \$send )->mode, 'wa' );
is( io( 'foo', '>', \$recv )->mode, 'r' );
is( io( 'foo', '>>', \$recv )->mode, 'ra' );
SKIP: {
if ( IPC::Run::Win32_MODE() ) {
skip( "$^O does not allow select() on non-sockets", 9 );
}
##
## Input from a file
##
SCOPE: {
spit $in_file, $text;
$recv = 'REPLACE ME';
$fd_map = _map_fds;
$r = run io( $in_file, '>', \$recv );
wipe $in_file;
ok($r);
}
ok( !$? );
is( _map_fds, $fd_map );
is( $recv, $text );
##
## Output to a file
##
SCOPE: {
wipe $out_file;
$send = $text;
$fd_map = _map_fds;
$r = run io( $out_file, '<', \$send );
$recv = slurp $out_file;
wipe $out_file;
ok($r);
}
ok( !$? );
is( _map_fds, $fd_map );
is( $send, $text );
is( $recv, $text );
}
|
