This patch:
- implements Apache::SubProcess::spawn_proc_prog (which allows to run a
program in a spawned process and provides in/out/err pipes to it)
Issues:
- optional functions use explodes during compilation under 5.6.1 (have no
idea why, it compiles cleanly with bleadperl)
- need more error checkings
Index: xs/maps/modperl_functions.map
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/maps/modperl_functions.map,v
retrieving revision 1.29
diff -u -r1.29 modperl_functions.map
--- xs/maps/modperl_functions.map 2001/11/15 18:19:56 1.29
+++ xs/maps/modperl_functions.map 2001/12/14 18:14:40
@@ -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
--- /dev/null Thu Jan 1 07:30:00 1970
+++ t/response/TestApache/subprocess.pm Sat Dec 15 01:37:01 2001
@@ -0,0 +1,116 @@
+package TestApache::subprocess;
+
+use strict;
+use warnings FATAL => 'all';
+
+use Apache::Const -compile => 'OK';
+#use APR::Const -compile => 'SUCCESS';
+
+use Apache::Test;
+use Apache::TestUtil;
+use File::Spec::Functions qw(catfile catdir);
+
+
+use Apache::SubProcess ();
+
+# XXX: this should go away, when send_fd() is implemented
+use Apache::compat;
+
+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 => 4;
+ my $target_dir = catfile $vars->{documentroot}, "util";
+ my $id = 0;
+
+ {
+ # test: passing argv + scalar context
+ $id++;
+ my $command = catfile $target_dir, "argv.pl";
+ my @argv = ('ok', $id);
+ my $in = Apache::SubProcess::spawn_proc_prog($r, $command, \@argv);
+ ok t_cmp(\@argv,
+ [split / /, <$in>],
+ "testing argv"
+ );
+ }
+
+ {
+ # test: passing env to subprocess through subprocess_env
+ $id++;
+ t_debug("testing subprocess_env");
+ my $command = catfile $target_dir, "env.pl";
+ $r->subprocess_env->set(SubProcess => "ok $id\n");
+ my $in = Apache::SubProcess::spawn_proc_prog($r, $command);
+ $r->send_fd($in);
+ $r->rflush;
+ }
+
+ {
+ # test: subproc's stdin -> stdout + list context
+ $id++;
+ my $command = catfile $target_dir, "in_out.pl";
+ my ($in, $out, $err) =
+ Apache::SubProcess::spawn_proc_prog($r, $command);
+ print $out "ok $id\n";
+ $r->send_fd($in);
+ }
+
+ {
+ # test: subproc's stdin -> stderr + list context
+ $id++;
+ my $command = catfile $target_dir, "in_err.pl";
+ my ($in, $out, $err) =
+ Apache::SubProcess::spawn_proc_prog($r, $command);
+ print $out "ok $id\n";
+ $r->send_fd($err);
+ }
+
+# 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
--- /dev/null Thu Jan 1 07:30:00 1970
+++ xs/Apache/SubProcess/Apache__SubProcess.h Sat Dec 15 01:47:40 2001
@@ -0,0 +1,178 @@
+#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->out;
+ if (!script_in)
+ return APR_EBADF;
+ apr_file_pipe_timeout_set(*script_in,
+ (int)(r->server->timeout * APR_USEC_PER_SEC));
+
+ *script_out = procnew->in;
+ if (!script_out)
+ 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)
+ 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;
+
+ /* XXX: more args here! */
+ if (items < 2) {
+ Perl_croak(aTHX_ "Usage: XXX");
+ }
+
+ 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) {
+ /* XXX: should test if it a ref to an array before deref it */
+ av_argv = (AV*)SvRV(ST(2));
+ }
+ 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]);
+ Perl_warn(aTHX_ "arg: %d %s\n", i, argv[i+1]);
+ }
+ 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) {
+ /* need to do lots of error checking before putting on
+ * stack */
+ XPUSHs(apr_file_to_glob(aTHX_ script_in,
+ r->pool, APR_PERLIO_HOOK_READ));
+ rc = apr_file_close(script_out);
+ 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_READ));
+ XPUSHs(apr_file_to_glob(aTHX_ script_out,
+ r->pool, APR_PERLIO_HOOK_WRITE));
+ XPUSHs(apr_file_to_glob(aTHX_ script_err,
+ r->pool, APR_PERLIO_HOOK_READ));
+ }
+ }
+ else {
+ XSRETURN_UNDEF;
+ }
+ }
+
+ PUTBACK;
+}
--- /dev/null Thu Jan 1 07:30:00 1970
+++ xs/Apache/SubProcess/SubProcess_pm Fri Dec 14 13:14:04 2001
@@ -0,0 +1 @@
+use APR::PerlIO ();
_____________________________________________________________________
Stas Bekman JAm_pH -- Just Another mod_perl Hacker
http://stason.org/ mod_perl Guide http://perl.apache.org/guide
mailto:[EMAIL PROTECTED] http://ticketmaster.com http://apacheweek.com
http://singlesheaven.com http://perl.apache.org http://perlmonth.com/
---------------------------------------------------------------------
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
