perl-modperl-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From s...@apache.org
Subject cvs commit: modperl-2.0/xs/maps modperl_functions.map
Date Mon, 17 Dec 2001 16:22:07 GMT
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
  
  
  

Mime
View raw message