perl-dev mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From Stas Bekman <s...@stason.org>
Subject Re: [mp2 bug] Perl*Env issues
Date Thu, 30 Dec 2004 22:45:08 GMT
I have finally figured it out. One needed to sync top-level dcfg too. Now

   PerlSetEnv Foo Bar

and

   $ENV{Foo} = "Bar";

are really interchangable for the *server* level config. So perl sees what 
PerlSetEnv (or PerlPassEnv) set and vice versa.

On the way I've found a few more problems and resolved them.

Please take a look (especially at the new test) and let me know if you see 
any problems.

You can enabled tracing to see what's going on:

   MOD_PERL_TRACE=de t/modperl/setupenv2.t

to see what's going on (note that some things will go to the console 
others to error_log).

Index: src/modules/perl/modperl_config.c
===================================================================
--- src/modules/perl/modperl_config.c	(revision 123523)
+++ src/modules/perl/modperl_config.c	(working copy)
@@ -21,6 +21,8 @@

      dcfg->location = dir;

+    MP_TRACE_d(MP_FUNC, "dir %s\n", dir);
+
  #ifdef USE_ITHREADS
      /* defaults to per-server scope */
      dcfg->interp_scope = MP_INTERP_SCOPE_UNDEF;
@@ -107,8 +109,9 @@
          *add  = (modperl_config_dir_t *)addv,
          *mrg  = modperl_config_dir_new(p);

-    MP_TRACE_d(MP_FUNC, "basev==0x%lx, addv==0x%lx\n",
-               (unsigned long)basev, (unsigned long)addv);
+    MP_TRACE_d(MP_FUNC, "basev==0x%lx, addv==0x%lx, mrg==0x%lx\n",
+               (unsigned long)basev, (unsigned long)addv,
+               (unsigned long)mrg);

  #ifdef USE_ITHREADS
      merge_item(interp_scope);
@@ -155,7 +158,8 @@

      scfg->PerlModule  = apr_array_make(p, 2, sizeof(char *));
      scfg->PerlRequire = apr_array_make(p, 2, sizeof(char *));
-    scfg->PerlPostConfigRequire = apr_array_make(p, 1, sizeof(char *));
+    scfg->PerlPostConfigRequire =
+        apr_array_make(p, 1, sizeof(modperl_require_file_t *));

      scfg->argv = apr_array_make(p, 2, sizeof(char *));

@@ -280,8 +284,9 @@
          *add  = (modperl_config_srv_t *)addv,
          *mrg  = modperl_config_srv_new(p);

-    MP_TRACE_d(MP_FUNC, "basev==0x%lx, addv==0x%lx\n",
-               (unsigned long)basev, (unsigned long)addv);
+    MP_TRACE_d(MP_FUNC, "basev==0x%lx, addv==0x%lx, mrg==0x%lx\n",
+               (unsigned long)basev, (unsigned long)addv,
+               (unsigned long)mrg);

      merge_item(modules);
      merge_item(PerlModule);
@@ -443,26 +448,28 @@
                                                 modperl_config_srv_t *scfg,
                                                 apr_pool_t *p)
  {
-    char **requires;
+    modperl_require_file_t **requires;
      int i;
      MP_PERL_CONTEXT_DECLARE;

-    requires = (char **)scfg->PerlPostConfigRequire->elts;
+    requires = (modperl_require_file_t **)scfg->PerlPostConfigRequire->elts;
      for (i = 0; i < scfg->PerlPostConfigRequire->nelts; i++){
          int retval;

          MP_PERL_CONTEXT_STORE_OVERRIDE(scfg->mip->parent->perl);
-        retval = modperl_require_file(aTHX_ requires[i], TRUE);
+        retval = modperl_require_file(aTHX_ requires[i]->file, TRUE);
+        modperl_env_sync_srv_env_hash2table(aTHX_ p, scfg);
+        modperl_env_sync_dir_env_hash2table(aTHX_ p, requires[i]->dcfg);
          MP_PERL_CONTEXT_RESTORE;

          if (retval) {
              MP_TRACE_d(MP_FUNC, "loaded Perl file: %s for server %s\n",
-                       requires[i], modperl_server_desc(s, p));
+                       requires[i]->file, modperl_server_desc(s, p));
          }
          else {
              ap_log_error(APLOG_MARK, APLOG_ERR, 0, s,
                           "Can't load Perl file: %s for server %s, 
exiting...",
-                         requires[i], modperl_server_desc(s, p));
+                         requires[i]->file, modperl_server_desc(s, p));

              return FALSE;
          }
Index: src/modules/perl/modperl_types.h
===================================================================
--- src/modules/perl/modperl_types.h	(revision 123523)
+++ src/modules/perl/modperl_types.h	(working copy)
@@ -165,6 +165,11 @@
  #endif
  } modperl_config_dir_t;

+typedef struct {
+    const char *file;
+    modperl_config_dir_t *dcfg;
+} modperl_require_file_t;
+
  typedef struct modperl_mgv_t modperl_mgv_t;

  struct modperl_mgv_t {
Index: src/modules/perl/modperl_env.c
===================================================================
--- src/modules/perl/modperl_env.c	(revision 123523)
+++ src/modules/perl/modperl_env.c	(working copy)
@@ -28,23 +28,27 @@
  #endif
  }

-static MP_INLINE
-void modperl_env_hv_store(pTHX_ HV *hv, apr_table_entry_t *elt)
+#define MP_ENV_HV_STORE(hv, key, val) STMT_START {              \
+        I32 klen = strlen(key);                                 \
+        SV **svp = hv_fetch(hv, key, klen, FALSE);              \
+                                                                \
+        if (svp) {                                              \
+            sv_setpv(*svp, val);                                \
+        }                                                       \
+        else {                                                  \
+            SV *sv = newSVpv(val, 0);                           \
+            hv_store(hv, key, klen, sv, FALSE);                 \
+            modperl_envelem_tie(sv, key, klen);                 \
+            svp = &sv;                                          \
+        }                                                       \
+        MP_TRACE_e(MP_FUNC, "$ENV{%s} = \"%s\";", key, val);    \
+                                                                \
+        SvTAINTED_on(*svp);                                     \
+    } STMT_END
+
+void modperl_env_hv_store(pTHX_ const char *key, const char *val)
  {
-    I32 klen = strlen(elt->key);
-    SV **svp = hv_fetch(hv, elt->key, klen, FALSE);
-
-    if (svp) {
-        sv_setpv(*svp, elt->val);
-    }
-    else {
-        SV *sv = newSVpv(elt->val, 0);
-        hv_store(hv, elt->key, klen, sv, FALSE);
-        modperl_envelem_tie(sv, elt->key, klen);
-        svp = &sv;
-    }
-
-    SvTAINTED_on(*svp);
+    MP_ENV_HV_STORE(ENVHV, key, val);
  }

  static MP_INLINE
@@ -98,6 +102,9 @@
      modperl_env_tie(mg_flags);
  }

+#define MP_ENV_HV_STORE_TABLE_ENTRY(hv, elt)    \
+    MP_ENV_HV_STORE(hv, elt.key, elt.val);
+
  static void modperl_env_table_populate(pTHX_ apr_table_t *table)
  {
      HV *hv = ENVHV;
@@ -115,9 +122,7 @@
          if (!elts[i].key || !elts[i].val) {
              continue;
          }
-        modperl_env_hv_store(aTHX_ hv, &elts[i]);
-
-        MP_TRACE_e(MP_FUNC, "$ENV{%s} = \"%s\";", elts[i].key, elts[i].val);
+        MP_ENV_HV_STORE_TABLE_ENTRY(hv, elts[i]);
      }

      modperl_env_tie(mg_flags);
@@ -141,13 +146,60 @@
              continue;
          }
          modperl_env_hv_delete(aTHX_ hv, elts[i].key);
-
          MP_TRACE_e(MP_FUNC, "delete $ENV{%s};", elts[i].key);
-    }
+    }

      modperl_env_tie(mg_flags);
  }

+/* see the comment in modperl_env_sync_env_hash2table */
+static void modperl_env_sync_table(pTHX_ apr_table_t *table)
+{
+    int i;
+    const apr_array_header_t *array;
+    apr_table_entry_t *elts;
+    HV *hv = ENVHV;
+    SV **svp;
+
+    array = apr_table_elts(table);
+    elts  = (apr_table_entry_t *)array->elts;
+
+    for (i = 0; i < array->nelts; i++) {
+        if (!elts[i].key) {
+            continue;
+        }
+        svp = hv_fetch(hv, elts[i].key, strlen(elts[i].key), FALSE);
+        if (svp) {
+            apr_table_set(table, elts[i].key, SvPV_nolen(*svp));
+            MP_TRACE_e(MP_FUNC, "(Set|Pass)Env '%s' '%s'", elts[i].key,
+                       SvPV_nolen(*svp));
+        }
+    }
+    TAINT_NOT; /* SvPV_* causes the taint issue */
+}
+
+/* Make per-server PerlSetEnv and PerlPassEnv in sync with %ENV at
+ * config time (if perl is running), by copying %ENV values to the
+ * PerlSetEnv and PerlPassEnv tables (only for keys which are already
+ * in those tables)
+ */
+void modperl_env_sync_srv_env_hash2table(pTHX_ apr_pool_t *p,
+                                         modperl_config_srv_t *scfg)
+{
+    MP_TRACE_d(MP_FUNC, "******* scfg==0x%lx, scfg->SetEnv==0x%lx\n",
+               (unsigned long)scfg, (unsigned long)scfg->SetEnv);
+    modperl_env_sync_table(aTHX_ scfg->SetEnv);
+    modperl_env_sync_table(aTHX_ scfg->PassEnv);
+}
+
+void modperl_env_sync_dir_env_hash2table(pTHX_ apr_pool_t *p,
+                                         modperl_config_dir_t *dcfg)
+{
+    MP_TRACE_d(MP_FUNC, "******* dcfg==0x%lx, dcfg->SetEnv==0x%lx\n",
+               (unsigned long)dcfg, (unsigned long)dcfg->SetEnv);
+    modperl_env_sync_table(aTHX_ dcfg->SetEnv);
+}
+
  /* list of environment variables to pass by default */
  static const char *MP_env_pass_defaults[] = {
      "PATH", "TZ", NULL
@@ -578,7 +630,7 @@
      0
  };

-static MGVTBL MP_vtbl_envelem =	{
+static MGVTBL MP_vtbl_envelem = {
      0,
      MEMBER_TO_FPTR(modperl_env_magic_set),
      0,
Index: src/modules/perl/modperl_env.h
===================================================================
--- src/modules/perl/modperl_env.h	(revision 123523)
+++ src/modules/perl/modperl_env.h	(working copy)
@@ -33,6 +33,14 @@

  void modperl_env_clear(pTHX);

+void modperl_env_hv_store(pTHX_ const char *key, const char *val);
+
+void modperl_env_sync_srv_env_hash2table(pTHX_ apr_pool_t *p,
+                                         modperl_config_srv_t *scfg);
+
+void modperl_env_sync_dir_env_hash2table(pTHX_ apr_pool_t *p,
+                                         modperl_config_dir_t *dcfg);
+
  void modperl_env_configure_server(pTHX_ apr_pool_t *p, server_rec *s);

  void modperl_env_configure_request_srv(pTHX_ request_rec *r);
Index: src/modules/perl/modperl_cmd.c
===================================================================
--- src/modules/perl/modperl_cmd.c	(revision 123523)
+++ src/modules/perl/modperl_cmd.c	(working copy)
@@ -133,30 +133,26 @@
      return NULL;
  }

+/* this test shows whether the perl for the current s is running
+ * (either base or vhost) */
  static int modperl_vhost_is_running(server_rec *s)
  {
  #ifdef USE_ITHREADS
-    MP_dSCFG(s);
-    int is_vhost = (s != modperl_global_get_server_rec());
+    if (s->is_virtual){
+        MP_dSCFG(s);
+        return scfg->mip ? TRUE : FALSE;
+    }
+#endif

-    if (is_vhost && scfg->mip) {
-        return TRUE;
-    }
-    else {
-        return FALSE;
-    }
-#else
      return modperl_is_running();
-#endif
+
  }

  MP_CMD_SRV_DECLARE(switches)
  {
      server_rec *s = parms->server;
      MP_dSCFG(s);
-    if (s->is_virtual
-        ? modperl_vhost_is_running(s)
-        : modperl_is_running() ) {
+    if (modperl_vhost_is_running(s)) {
          return modperl_cmd_too_late(parms);
      }
      MP_TRACE_d(MP_FUNC, "arg = %s\n", arg);
@@ -167,6 +163,7 @@
  MP_CMD_SRV_DECLARE(modules)
  {
      MP_dSCFG(parms->server);
+    modperl_config_dir_t *dcfg = (modperl_config_dir_t *)mconfig;
      MP_PERL_CONTEXT_DECLARE;

      MP_CHECK_SERVER_OR_HTACCESS_CONTEXT;
@@ -186,6 +183,10 @@
          if (!modperl_require_module(aTHX_ arg, FALSE)) {
              error = SvPVX(ERRSV);
          }
+        else {
+            modperl_env_sync_srv_env_hash2table(aTHX_ parms->pool, scfg);
+            modperl_env_sync_dir_env_hash2table(aTHX_ parms->pool, dcfg);
+        }
          MP_PERL_CONTEXT_RESTORE;

          return error;
@@ -200,6 +201,7 @@
  MP_CMD_SRV_DECLARE(requires)
  {
      MP_dSCFG(parms->server);
+    modperl_config_dir_t *dcfg = (modperl_config_dir_t *)mconfig;
      MP_PERL_CONTEXT_DECLARE;

      MP_CHECK_SERVER_OR_HTACCESS_CONTEXT;
@@ -219,6 +221,10 @@
          if (!modperl_require_file(aTHX_ arg, FALSE)) {
              error = SvPVX(ERRSV);
          }
+        else {
+            modperl_env_sync_srv_env_hash2table(aTHX_ parms->pool, scfg);
+            modperl_env_sync_dir_env_hash2table(aTHX_ parms->pool, dcfg);
+        }
          MP_PERL_CONTEXT_RESTORE;

          return error;
@@ -244,15 +250,19 @@
  MP_CMD_SRV_DECLARE(post_config_requires)
  {
      apr_pool_t *p = parms->pool;
+    modperl_config_dir_t *dcfg = (modperl_config_dir_t *)mconfig;
      apr_finfo_t finfo;
      MP_dSCFG(parms->server);

      if (APR_SUCCESS == apr_stat(&finfo, arg, APR_FINFO_TYPE, p)) {
          if (finfo.filetype != APR_NOFILE) {
              MP_TRACE_d(MP_FUNC, "push PerlPostConfigRequire for %s\n", arg);
-
-            *(const char **)
-                apr_array_push(scfg->PerlPostConfigRequire) = arg;
+            modperl_require_file_t *require = apr_pcalloc(p, 
sizeof(*require));
+            require->file = arg;
+            require->dcfg = dcfg;
+
+            *(modperl_require_file_t **)
+                apr_array_push(scfg->PerlPostConfigRequire) = require;
          }
      }
      else {
@@ -331,6 +341,13 @@
      if (!parms->path) {
          /* will be propagated to environ */
          apr_table_setn(scfg->SetEnv, arg1, arg2);
+        /* sync SetEnv => %ENV only for the top-level values */
+        if (modperl_vhost_is_running(parms->server)) {
+            MP_PERL_CONTEXT_DECLARE;
+            MP_PERL_CONTEXT_STORE_OVERRIDE(scfg->mip->parent->perl);
+            modperl_env_hv_store(aTHX_ arg1, arg2);
+            MP_PERL_CONTEXT_RESTORE;
+        }
      }

      apr_table_setn(dcfg->SetEnv, arg1, arg2);
@@ -353,6 +370,12 @@

      if (val) {
          apr_table_setn(scfg->PassEnv, arg, apr_pstrdup(parms->pool, val));
+        if (modperl_vhost_is_running(parms->server)) {
+            MP_PERL_CONTEXT_DECLARE;
+            MP_PERL_CONTEXT_STORE_OVERRIDE(scfg->mip->parent->perl);
+            modperl_env_hv_store(aTHX_ arg, val);
+            MP_PERL_CONTEXT_RESTORE;
+        }
          MP_TRACE_d(MP_FUNC, "arg = %s, val = %s\n", arg, val);
      }
      else {
@@ -475,6 +498,7 @@
  {
      apr_pool_t *p = parms->pool;
      server_rec *s = parms->server;
+    modperl_config_dir_t *dcfg = (modperl_config_dir_t *)mconfig;
      apr_table_t *options;
      modperl_handler_t *handler = NULL;
      const char *pkg_name = NULL;
@@ -541,6 +565,8 @@
          save_scalar(gv); /* local $0 */
          sv_setpv_mg(GvSV(gv), directive->filename);
          eval_pv(arg, FALSE);
+        modperl_env_sync_srv_env_hash2table(aTHX_ p, scfg);
+        modperl_env_sync_dir_env_hash2table(aTHX_ p, dcfg);
          FREETMPS;LEAVE;
      }

--- /dev/null	2004-12-27 14:35:25.636826264 -0500
+++ t/response/TestModperl/setupenv2.pm	2004-12-30 17:33:51.740555289 -0500
@@ -0,0 +1,135 @@
+package TestModperl::setupenv2;
+
+# Test the mixing of PerlSetEnv in httpd.conf and %ENV of the same
+# key in PerlRequire, PerlConfigRequire, PerlPostConfigRequire and
+# <Perl> sections
+
+use strict;
+use warnings FATAL => 'all';
+
+use Apache::Const -compile => qw(OK OR_ALL NO_ARGS);
+
+use Apache::CmdParms ();
+use Apache::Module ();
+use Apache::RequestIO ();
+use Apache::RequestRec ();
+
+my @directives = (
+    {
+     name         => 'MyEnvRegister',
+     func         => __PACKAGE__ . '::MyEnvRegister',
+     req_override => Apache::OR_ALL,
+     args_how     => Apache::NO_ARGS,
+     errmsg       => 'cannot fail :)',
+    },
+);
+
+Apache::Module::add(__PACKAGE__, \@directives);
+
+# testing PerlLoadModule
+$ENV{EnvChangeMixedTest} = 'loadmodule';
+$ENV{EnvChangePerlTest}  = 'loadmodule';
+
+sub MyEnvRegister {
+    register_mixed();
+}
+
+sub register_mixed {
+    push @TestModperl::setupenv2::EnvChangeMixedTest,
+        $ENV{EnvChangeMixedTest} || 'notset';
+}
+
+sub register_perl {
+    push @TestModperl::setupenv2::EnvChangePerlTest,
+        $ENV{EnvChangePerlTest}  || 'notset';
+}
+
+sub get_config {
+    my($self, $s) = (shift, shift);
+    Apache::Module::get_config($self, $s, @_);
+}
+
+sub handler {
+    my($r) = @_;
+
+    # what's the latest env value
+    register_mixed();
+    register_perl();
+
+    my $args = $r->args || '';
+
+    $r->content_type('text/plain');
+
+    if ($args eq 'mixed') {
+        $r->print( join " ", @TestModperl::setupenv2::EnvChangeMixedTest);
+    }
+    elsif ($args eq 'perl') {
+        $r->print( join " ", @TestModperl::setupenv2::EnvChangePerlTest);
+
+    }
+    else {
+        die "no such case";
+    }
+
+    return Apache::OK;
+}
+
+1;
+__END__
+
+# APACHE_TEST_CONFIG_ORDER 950
+
+<NoAutoConfig>
+PerlLoadModule TestModperl::setupenv2
+MyEnvRegister
+
+PerlSetEnv EnvChangeMixedTest "conf1"
+
+<Perl>
+TestModperl::setupenv2::register_mixed();
+TestModperl::setupenv2::register_perl();
+$ENV{EnvChangeMixedTest} = "<perl>";
+$ENV{EnvChangePerlTest}  = "<perl>";
+</Perl>
+MyEnvRegister
+
+PerlSetEnv EnvChangeMixedTest "conf2"
+
+PerlRequire           "@documentroot@/modperl/setupenv2/require.pl"
+MyEnvRegister
+
+PerlSetEnv EnvChangeMixedTest "conf3"
+
+PerlConfigRequire     "@documentroot@/modperl/setupenv2/config_require.pl"
+MyEnvRegister
+
+PerlSetEnv EnvChangeMixedTest "conf4"
+
+PerlModule htdocs::modperl::setupenv2::module
+MyEnvRegister
+
+PerlSetEnv EnvChangeMixedTest "conf5"
+MyEnvRegister
+
+PerlPostConfigRequire 
"@documentroot@/modperl/setupenv2/post_config_require.pl"
+MyEnvRegister
+
+PerlSetEnv EnvChangeMixedTest "conf6"
+MyEnvRegister
+
+PerlSetEnv EnvChangeMixedTest "conf7"
+MyEnvRegister
+
+<Location /TestModperl__setupenv2>
+    SetHandler modperl
+    PerlResponseHandler TestModperl::setupenv2
+</Location>
+
+PerlSetEnv EnvChangeMixedTest "conf8"
+
+# Since PerlPostConfigRequire runs in the post-config phase it will
+# see 'conf8'. And when it sets that value to 'post_config_require' at
+# request time $ENV{EnvChangeMixedTest} will see the value set by
+# PerlPostConfigRequire.
+
+</NoAutoConfig>

--- /dev/null	2004-12-27 14:35:25.636826264 -0500
+++ t/modperl/setupenv2.t	2004-12-30 16:26:32.995140510 -0500
@@ -0,0 +1,35 @@
+use strict;
+use warnings FATAL => 'all';
+
+use Apache::Test;
+use Apache::TestUtil;
+use Apache::TestRequest;
+
+my $location = "/TestModperl__setupenv2";
+
+my %expected = (
+    mixed => [qw(loadmodule conf1 <perl> conf2 require conf3
+                config_require conf4 perlmodule conf5 conf5
+                conf6 conf7 conf8 post_config_require)],
+    perl  => [qw(loadmodule <perl> require config_require
+                perlmodule post_config_require)],
+);
+
+plan tests => 2 + scalar(@{ $expected{mixed} }) + scalar(@{ 
$expected{perl} });
+
+while (my($k, $v) = each %expected) {
+    my @expected = @$v;
+    my $elements = scalar @expected;
+    my $received = GET_BODY "$location?$k";
+    t_debug "$k: $received";
+    my @received = split / /, $received;
+
+    ok t_cmp $received[$_], $expected[$_] for 0..$#expected;
+
+    ok t_cmp scalar(@received), scalar(@expected), "elements";
+    if (@received > @expected) {
+        t_debug "unexpected elements: " .
+            join " ", @received[$elements..$#received];
+    }
+}
+

-- 
__________________________________________________________________
Stas Bekman            JAm_pH ------> Just Another mod_perl Hacker
http://stason.org/     mod_perl Guide ---> http://perl.apache.org
mailto:stas@stason.org http://use.perl.org http://apacheweek.com
http://modperlbook.org http://apache.org   http://ticketmaster.com

---------------------------------------------------------------------
To unsubscribe, e-mail: dev-unsubscribe@perl.apache.org
For additional commands, e-mail: dev-help@perl.apache.org


Mime
View raw message