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 06:24:06 GMT
Pratik wrote:
>>I don't think this problem can be fixed. That means that if someone mixes
>>and matches PerlSetEnv (or PerlPassEnv) in httpd.conf and %ENV of the same
>>key in PerlRequire, PerlConfigRequire, PerlPostConfigRequire and <Perl>
>>sections. Whatever was the last value of that key before <Location> or
>><Directory> was encountered, that will be the value that any
>>post-post_config handler will see  when called for that container.
>>
>>Let me know if that's OK with you.
>>
> 
> 
> Yeah ! That's great :)

I'm not happy about this. I've extended the test a bit more and I see 
weird things. With the following patch and when running the test as:

env MOD_PERL_TRACE=all t/TEST -v t/modperl/setupenv2.t > & mylog

I get (mylog):

modperl_config_srv_merge: basev==0x8160ad8, addv==0x94142a0

modperl_apr_table_dump: *** Contents of table 'base scfg->SetEnv' ***
modperl_apr_table_dump: TestDirective__env_srv1 => env_srv1
modperl_apr_table_dump: TestDirective__env_srv2 => env_srv2
modperl_apr_table_dump: EnvChangeMixedTest      => perlmodule
modperl_apr_table_dump:
modperl_apr_table_dump: *** Contents of table 'add  scfg->SetEnv' ***
modperl_apr_table_dump:
[...]
modperl_config_dir_new: new dcfg: 0x9489700

modperl_config_dir_merge: basev==0x81616d0, addv==0x941c000

modperl_apr_table_dump: *** Contents of table 'base dcfg->SetEnv' ***
modperl_apr_table_dump: TestDirective__env_srv1 => env_srv1
modperl_apr_table_dump: TestDirective__env_srv2 => env_srv2
modperl_apr_table_dump: EnvChangeMixedTest      => conf4
modperl_apr_table_dump:
modperl_apr_table_dump: *** Contents of table 'add  dcfg->SetEnv' ***
modperl_apr_table_dump:

so the server's merge sees 'perlmodule' set by PerlModule (and resynced 
into scfg->SetEnv), but the dir config sees the last value set by 
PerlSetEnv. I don't understand why the 'base->SetEnv' in 
modperl_config_dir_merge is not the same as the server. That looks like a 
bug or something.

Index: src/modules/perl/modperl_debug.c
===================================================================
--- src/modules/perl/modperl_debug.c	(revision 123523)
+++ src/modules/perl/modperl_debug.c	(working copy)
@@ -43,22 +43,32 @@


  #ifdef MP_TRACE
-/* any non-false value for MOD_PERL_TRACE/PerlTrace enables this function */
  void modperl_apr_table_dump(pTHX_ apr_table_t *table, char *name)
  {
-    int i;
-    const apr_array_header_t *array;
-    apr_table_entry_t *elts;
+    int i, tmp_len, len = 0;
+    char *fmt;
+    const apr_array_header_t *array = apr_table_elts(table);
+    apr_table_entry_t *elts  = (apr_table_entry_t *)array->elts;

-    array = apr_table_elts(table);
-    elts  = (apr_table_entry_t *)array->elts;
-    modperl_trace(MP_FUNC, "Contents of table %s", name);
+    modperl_trace(MP_FUNC, "*** Contents of table '%s' ***", name);
      for (i = 0; i < array->nelts; i++) {
+        if (elts[i].key && elts[i].val) {
+            tmp_len = strlen(elts[i].key);
+            if (tmp_len > len) {
+                len = tmp_len;
+            }
+        }
+    }
+    /* dump the table with keys aligned */
+    fmt = Perl_form(aTHX_ "%%-%ds => %%s", len);
+
+    for (i = 0; i < array->nelts; i++) {
          if (!elts[i].key || !elts[i].val) {
              continue;
          }
-        modperl_trace(MP_FUNC, "%s => %s", elts[i].key, elts[i].val);
+        modperl_trace(MP_FUNC, fmt, elts[i].key, elts[i].val);
      }
+    modperl_trace(MP_FUNC, "");
  }
  #endif

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

      merge_item(location);

+    dTHX;
+    modperl_apr_table_dump(aTHX_ (apr_table_t *)base->SetEnv,
+                           "base dcfg->SetEnv");
+    modperl_apr_table_dump(aTHX_ (apr_table_t *)add->SetEnv,
+                           "add  dcfg->SetEnv");
+
      merge_table_overlap_item(SetEnv);

      /* this is where we merge PerlSetVar and PerlAddVar together */
@@ -288,6 +294,12 @@
      merge_item(PerlRequire);
      merge_item(PerlPostConfigRequire);

+    dTHX;
+    modperl_apr_table_dump(aTHX_ (apr_table_t *)base->SetEnv,
+                           "base scfg->SetEnv");
+    modperl_apr_table_dump(aTHX_ (apr_table_t *)add->SetEnv,
+                           "add  scfg->SetEnv");
+
      merge_table_overlap_item(SetEnv);
      merge_table_overlap_item(PassEnv);

@@ -453,6 +465,7 @@

          MP_PERL_CONTEXT_STORE_OVERRIDE(scfg->mip->parent->perl);
          retval = modperl_require_file(aTHX_ requires[i], TRUE);
+        modperl_env_sync_env_hash2table(aTHX_ p, s);
          MP_PERL_CONTEXT_RESTORE;

          if (retval) {
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,51 @@
              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_env_hash2table(pTHX_ apr_pool_t *p, server_rec *s)
+{
+    MP_dSCFG(s);
+
+    modperl_env_sync_table(aTHX_ scfg->SetEnv);
+    modperl_env_sync_table(aTHX_ scfg->PassEnv);
+}
+
  /* list of environment variables to pass by default */
  static const char *MP_env_pass_defaults[] = {
      "PATH", "TZ", NULL
@@ -578,7 +621,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,10 @@

  void modperl_env_clear(pTHX);

+void modperl_env_hv_store(pTHX_ const char *key, const char *val);
+
+void modperl_env_sync_env_hash2table(pTHX_ apr_pool_t *p, server_rec *s);
+
  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)
@@ -186,6 +186,9 @@
          if (!modperl_require_module(aTHX_ arg, FALSE)) {
              error = SvPVX(ERRSV);
          }
+        else {
+            modperl_env_sync_env_hash2table(aTHX_ parms->pool, 
parms->server);
+        }
          MP_PERL_CONTEXT_RESTORE;

          return error;
@@ -219,6 +222,9 @@
          if (!modperl_require_file(aTHX_ arg, FALSE)) {
              error = SvPVX(ERRSV);
          }
+        else {
+            modperl_env_sync_env_hash2table(aTHX_ parms->pool, 
parms->server);
+        }
          MP_PERL_CONTEXT_RESTORE;

          return error;
@@ -331,6 +337,12 @@
      if (!parms->path) {
          /* will be propagated to environ */
          apr_table_setn(scfg->SetEnv, arg1, arg2);
+        if (modperl_is_running()) {
+            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 +365,12 @@

      if (val) {
          apr_table_setn(scfg->PassEnv, arg, apr_pstrdup(parms->pool, val));
+        if (modperl_is_running()) {
+            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 {
@@ -541,6 +559,7 @@
          save_scalar(gv); /* local $0 */
          sv_setpv_mg(GvSV(gv), directive->filename);
          eval_pv(arg, FALSE);
+        modperl_env_sync_env_hash2table(aTHX_ p, s);
          FREETMPS;LEAVE;
      }

--- /dev/null	2004-12-27 14:35:25.636826264 -0500
+++ t/response/TestModperl/setupenv2.pm	2004-12-30 01:08:32.119169453 -0500
@@ -0,0 +1,150 @@
+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 ();
+use Apache::RequestUtil ();
+use Apache::ServerUtil ();
+
+use Apache::TestTrace;
+
+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} || 'undef';
+}
+
+sub register_perl {
+    push @TestModperl::setupenv2::EnvChangePerlTest,
+        $ENV{EnvChangePerlTest} || 'undef';
+}
+
+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";
+    }
+
+    warn "KEY: *******", $r->subprocess_env->get('EnvChangeMixedTest'), 
"******\n";
+
+    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"
+
+# at request time a request for <Location /TestModperl__setupenv2>
+# will see this value ("conf8") and
+
+# - not the value set by PerlPostConfigRequire (which is run the very
+# last from all these directives. That's because the PerlSetEnv table
+# for dir <Location /TestModperl__setupenv2> is set right after
+# EnvChangeMixedTest is set to "conf7".
+
+# even though conf8 is the latest setting (before
+# PerlPostConfigRequire) the response handler from <Location
+# /TestModperl__setupenv2> will see conf7, since it was the latest
+# value before that container was encountered
+
+
+</NoAutoConfig>

--- /dev/null	2004-12-27 14:35:25.636826264 -0500
+++ t/modperl/setupenv2.t	2004-12-29 23:47:33.977528198 -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 conf7)],
+    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