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
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
|
# please insert nothing before this line: -*- mode: cperl; cperl-indent-level: 4; cperl-continued-statement-offset: 4; indent-tabs-mode: nil -*-
package TestApache::subprocess;
use strict;
use warnings FATAL => 'all';
use Apache::Test;
use Apache::TestUtil;
use Apache2::Build;
use File::Spec::Functions qw(catfile catdir);
use IO::Select ();
use Apache2::Const -compile => 'OK';
use Config;
my $perl = Apache2::Build->build_config()->perl_config('perlpath');
my %scripts = (
argv => 'print STDOUT "@ARGV";',
env => 'print STDOUT $ENV{SubProcess}',
in_out => 'print STDOUT scalar <STDIN>;',
in_err => 'print STDERR scalar <STDIN>;',
);
sub APACHE_TEST_CONFIGURE {
my ($class, $self) = @_;
my $vars = $self->{vars};
my $target_dir = catdir $vars->{documentroot}, "util";
while (my ($file, $code) = each %scripts) {
$file = catfile $target_dir, "$file.pl";
$self->write_perlscript($file, "$code\n");
}
}
sub handler {
my $r = shift;
my $cfg = Apache::Test::config();
my $vars = $cfg->{vars};
plan $r, tests => 5, need qw(APR::PerlIO Apache2::SubProcess);
my $target_dir = catfile $vars->{documentroot}, "util";
{
# test: passing argv + void context
my $script = catfile $target_dir, "argv.pl";
my @argv = qw(foo bar);
$r->spawn_proc_prog($perl, [$script, @argv]);
# can't really test if something is still returned since it
# will be no longer void context
ok 1;
}
{
# test: passing argv + scalar context
my $script = catfile $target_dir, "argv.pl";
my @argv = qw(foo bar);
my $out_fh = $r->spawn_proc_prog($perl, [$script, @argv]);
my $output = read_data($out_fh);
ok t_cmp([split / /, $output],
\@argv,
"passing ARGV"
);
}
{
# test: passing env to subprocess through subprocess_env
my $script = catfile $target_dir, "env.pl";
my $value = "my cool proc";
$r->subprocess_env->set(SubProcess => $value);
my $out_fh = $r->spawn_proc_prog($perl, [$script]);
my $output = read_data($out_fh);
ok t_cmp($output,
$value,
"passing env via subprocess_env"
);
}
{
# test: subproc's stdin -> stdout + list context
my $script = catfile $target_dir, "in_out.pl";
my $value = "my cool proc\r\n"; # must have \n for <IN>
my ($in_fh, $out_fh, $err_fh) =
$r->spawn_proc_prog($perl, [$script]);
print $in_fh $value;
(my $output = read_data($out_fh)) =~ s/[\r\n]{1,2}/\r\n/;
ok t_cmp($output,
$value,
"testing subproc's stdin -> stdout + list context"
);
}
{
# test: subproc's stdin -> stderr + list context
my $script = catfile $target_dir, "in_err.pl";
my $value = "my stderr\r\n"; # must have \n for <IN>
my ($in_fh, $out_fh, $err_fh) =
$r->spawn_proc_prog($perl, [$script]);
print $in_fh $value;
(my $output = read_data($err_fh)) =~ s/[\r\n]{1,2}/\r\n/;
ok t_cmp($output,
$value,
"testing subproc's stdin -> stderr + list context"
);
}
# could test send_fd($out), send_fd($err), but currently it's only in
# compat.pm.
# these are wannabe's
# ok t_cmp(
# Apache2::SubProcess::spawn_proc_sub($r, $sub, \@args),
# Apache2::SUCCESS,
# "spawn a subprocess and run a subroutine in it"
# );
# ok t_cmp(
# Apache2::SubProcess::spawn_thread_prog($r, $command, \@argv),
# Apache2::SUCCESS,
# "spawn thread and run a program in it"
# );
# ok t_cmp(
# Apache2::SubProcess::spawn_thread_sub($r, $sub, \@args),
# Apache2::SUCCESS,
# "spawn thread and run a subroutine in it"
# );
Apache2::Const::OK;
}
sub read_data {
my ($fh) = @_;
my @data = ();
my $sel = IO::Select->new($fh);
# here is the catch:
#
# non-PerlIO pipe fh needs to select if the other end is not fast
# enough to send the data, since the read is non-blocking
#
# PerlIO-based pipe fh on the other hand does the select
# internally via apr_wait_for_io_or_timeout() in
# apr_file_read() (on *nix, but not on Win32).
# But you cannot call select() on the
# PerlIO-based, because its fileno() returns (-1), remember that
# apr_file_t is an opaque object, and on certain platforms
# fileno() is different from unix
#
# so we use the following wrapper: if we are under perlio we just
# go ahead and read the data, but with a short sleep first on Win32;
# if we are under non-perlio we first
# select for a few secs. (XXX: is 10 secs enough?)
#
# btw: we use perlIO only for perl 5.7+
#
if (APR::PerlIO::PERLIO_LAYERS_ARE_ENABLED() || $sel->can_read(10)) {
sleep(1) if $^O eq 'MSWin32' && APR::PerlIO::PERLIO_LAYERS_ARE_ENABLED();
@data = wantarray ? (<$fh>) : <$fh>;
}
if (wantarray) {
return @data;
}
else {
return defined $data[0] ? $data[0] : '';
}
}
1;
|
