You are viewing a plain text version of this content. The canonical link for it is here.
Posted to modperl-cvs@perl.apache.org by st...@apache.org on 2001/12/17 17:22:07 UTC
cvs commit: modperl-2.0/xs/maps modperl_functions.map
stas 01/12/17 08:22:07
Modified: xs/maps modperl_functions.map
Added: t/response/TestApache subprocess.pm
xs/Apache/SubProcess Apache__SubProcess.h SubProcess_pm
Log:
- implement Apache::SubProcess::spawn_proc_prog (which allows to run a
program in a spawned process and provides in/out/err pipes to it)
Revision Changes Path
1.1 modperl-2.0/t/response/TestApache/subprocess.pm
Index: subprocess.pm
===================================================================
package TestApache::subprocess;
use strict;
use warnings FATAL => 'all';
use Apache::Const -compile => 'OK';
use Apache::Test;
use Apache::TestUtil;
use File::Spec::Functions qw(catfile catdir);
use Apache::SubProcess ();
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};
# XXX: these tests randomly fail under 5.6.1
plan $r, todo => [1..4], tests => 4;
my $target_dir = catfile $vars->{documentroot}, "util";
{
# test: passing argv + scalar context
my $command = catfile $target_dir, "argv.pl";
my @argv = qw(foo bar);
my $out = Apache::SubProcess::spawn_proc_prog($r, $command, \@argv);
ok t_cmp(\@argv,
[split / /, <$out>],
"passing ARGV"
);
}
{
# test: passing env to subprocess through subprocess_env
my $command = catfile $target_dir, "env.pl";
my $value = "my cool proc";
$r->subprocess_env->set(SubProcess => $value);
my $out = Apache::SubProcess::spawn_proc_prog($r, $command);
ok t_cmp($value,
<$out>,
"passing env via subprocess_env"
);
}
{
# test: subproc's stdin -> stdout + list context
my $command = catfile $target_dir, "in_out.pl";
my $value = "my cool proc\n"; # must have \n for <IN>
my ($in, $out, $err) =
Apache::SubProcess::spawn_proc_prog($r, $command);
print $in $value;
ok t_cmp($value,
<$out>,
"testing subproc's stdin -> stdout + list context"
);
}
{
# test: subproc's stdin -> stderr + list context
my $command = catfile $target_dir, "in_err.pl";
my $value = "my stderr\n"; # must have \n for <IN>
my ($in, $out, $err) =
Apache::SubProcess::spawn_proc_prog($r, $command);
print $in $value;
ok t_cmp($value,
<$err>,
"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(
# Apache::SUCCESS,
# Apache::SubProcess::spawn_proc_sub($r, $sub, \@args),
# "spawn a subprocess and run a subroutine in it"
# );
# ok t_cmp(
# Apache::SUCCESS,
# Apache::SubProcess::spawn_thread_prog($r, $command, \@argv),
# "spawn thread and run a program in it"
# );
# ok t_cmp(
# Apache::SUCCESS,
# Apache::SubProcess::spawn_thread_sub($r, $sub, \@args),
# "spawn thread and run a subroutine in it"
# );
Apache::OK;
}
1;
__DATA__
PerlModule Apache::SubProcess
1.1 modperl-2.0/xs/Apache/SubProcess/Apache__SubProcess.h
Index: Apache__SubProcess.h
===================================================================
#include "../../APR/PerlIO/apr_perlio.h"
#ifndef MP_SOURCE_SCAN
#include "apr_optional.h"
#endif
#ifndef MP_SOURCE_SCAN
static APR_OPTIONAL_FN_TYPE(apr_perlio_apr_file_to_glob) *apr_file_to_glob;
#endif
/* XXX: probably needs a lot more error checkings */
typedef struct {
apr_int32_t in_pipe;
apr_int32_t out_pipe;
apr_int32_t err_pipe;
apr_cmdtype_e cmd_type;
} exec_info;
#define FAILED(command) ((rc = command) != APR_SUCCESS)
static int modperl_spawn_proc_prog(request_rec *r,
const char *command,
const char ***argv,
apr_file_t **script_in,
apr_file_t **script_out,
apr_file_t **script_err)
{
exec_info e_info;
apr_pool_t *p;
const char * const *env;
apr_procattr_t *procattr;
apr_proc_t *procnew;
apr_status_t rc = APR_SUCCESS;
e_info.in_pipe = APR_CHILD_BLOCK;
e_info.out_pipe = APR_CHILD_BLOCK;
e_info.err_pipe = APR_CHILD_BLOCK;
e_info.cmd_type = APR_PROGRAM;
p = r->main ? r->main->pool : r->pool;
*script_out = NULL;
*script_in = NULL;
*script_err = NULL;
env = (const char* const*)ap_create_environment(p, r->subprocess_env);
if ( FAILED(apr_procattr_create(&procattr, p)) ||
FAILED(apr_procattr_io_set(procattr, e_info.in_pipe,
e_info.out_pipe, e_info.err_pipe)) ||
FAILED(apr_procattr_dir_set(procattr,
ap_make_dirstr_parent(r->pool,
r->filename))) ||
FAILED(apr_procattr_cmdtype_set(procattr, e_info.cmd_type))) {
/* Something bad happened, tell the world. */
ap_log_rerror(APLOG_MARK, APLOG_ERR, rc, r,
"couldn't set child process attributes: %s",
r->filename);
return rc;
}
procnew = apr_pcalloc(p, sizeof(*procnew));
if FAILED(ap_os_create_privileged_process(r, procnew, command,
*argv, env, procattr, p)) {
/* Bad things happened. Everyone should have cleaned up. */
ap_log_rerror(APLOG_MARK, APLOG_ERR, rc, r,
"couldn't create child process: %d: %s", rc, r->filename);
return rc;
}
apr_pool_note_subprocess(p, procnew, kill_after_timeout);
*script_in = procnew->in;
if (!*script_in) {
croak("broken program-in stream");
return APR_EBADF;
}
apr_file_pipe_timeout_set(*script_in,
(int)(r->server->timeout * APR_USEC_PER_SEC));
*script_out = procnew->out;
if (!*script_out) {
croak("broken program-out stream");
return APR_EBADF;
}
apr_file_pipe_timeout_set(*script_out,
(int)(r->server->timeout * APR_USEC_PER_SEC));
*script_err = procnew->err;
if (!*script_err) {
croak("broken program-err stream");
return APR_EBADF;
}
apr_file_pipe_timeout_set(*script_err,
(int)(r->server->timeout * APR_USEC_PER_SEC));
return rc;
}
static XS(MPXS_modperl_spawn_proc_prog)
{
dXSARGS;
const char *usage = "Usage: spawn_proc_prog($r, $command, [\\@argv])";
if (items < 2) {
Perl_croak(aTHX_ usage);
}
SP -= items;
{
apr_file_t *script_in, *script_out, *script_err;
apr_status_t rc;
const char **argv;
int i;
AV *av_argv;
request_rec *r = modperl_xs_sv2request_rec(aTHX_ ST(0), NULL, cv);
const char *command = (const char *)SvPV_nolen(ST(1));
if (items == 3) {
if (SvROK(ST(2)) && SvTYPE(SvRV(ST(2))) == SVt_PVAV) {
av_argv = (AV*)SvRV(ST(2));
}
else {
Perl_croak(aTHX_ usage);
}
}
else {
av_argv = newAV();
}
/* ap_os_create_privileged_process expects ARGV as char
* **argv, with terminating NULL and the program itself as a
* first item.
*/
argv = apr_palloc(r->pool,
( 3 + av_len(av_argv) ) * sizeof(char*) );
argv[0] = command;
for (i = 0; i <= av_len(av_argv); i++) {
argv[i+1] = (const char *)SvPV_nolen(AvARRAY(av_argv)[i]);
}
argv[i+1] = NULL;
/* for (i=0; i<=av_len(av_argv)+2; i++) { */
/* Perl_warn(aTHX_ "arg: %d %s\n", i, argv[i]); */
/* } */
rc = modperl_spawn_proc_prog(r, command, &argv,
&script_in, &script_out,
&script_err);
if (rc == APR_SUCCESS) {
apr_file_to_glob =
APR_RETRIEVE_OPTIONAL_FN(apr_perlio_apr_file_to_glob);
if (GIMME == G_SCALAR) {
/* XXX: need to do lots of error checking before
* putting the object on the stack */
SV *out = apr_file_to_glob(aTHX_ script_out, r->pool,
APR_PERLIO_HOOK_READ);
XPUSHs(out);
rc = apr_file_close(script_in);
if (rc != APR_SUCCESS) {
XSRETURN_UNDEF;
}
rc = apr_file_close(script_err);
if (rc != APR_SUCCESS) {
XSRETURN_UNDEF;
}
}
else {
XPUSHs(apr_file_to_glob(aTHX_ script_in,
r->pool, APR_PERLIO_HOOK_WRITE));
XPUSHs(apr_file_to_glob(aTHX_ script_out,
r->pool, APR_PERLIO_HOOK_READ));
XPUSHs(apr_file_to_glob(aTHX_ script_err,
r->pool, APR_PERLIO_HOOK_READ));
}
}
else {
XSRETURN_UNDEF;
}
}
PUTBACK;
}
1.1 modperl-2.0/xs/Apache/SubProcess/SubProcess_pm
Index: SubProcess_pm
===================================================================
use APR::PerlIO ();
1.30 +4 -0 modperl-2.0/xs/maps/modperl_functions.map
Index: modperl_functions.map
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/maps/modperl_functions.map,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -r1.29 -r1.30
--- modperl_functions.map 2001/11/15 18:19:56 1.29
+++ modperl_functions.map 2001/12/17 16:22:07 1.30
@@ -90,3 +90,7 @@
PACKAGE=Apache
DEFINE_LOG_MARK | MPXS_Apache_LOG_MARK | ...
DEFINE_warn | MPXS_Apache__Log_log_error | ...
+
+MODULE=Apache::SubProcess
+ # ap_subprocess_ won't work
+ modperl_spawn_proc_prog | MPXS_ | ... | spawn_proc_prog