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 Tue, 28 Dec 2004 20:34:11 GMT
Pratik wrote:
> I've been trying get this patch working. The basic idea behind the patch is :
> 
> 1. Populate %ENV on occurrence of PerlPassEnv & PerlSetEnv.
> 2. After every <Perl>..</Perl>, PerlRequire, PerlModule &
> PerlLoadModule - sync server tables - scfg->SetEnv & scfg->PassEnv -
> with %ENV.
> 
> I believe it's failing because I am not checking if perl is
> initialized or not before calling modperl_env_hv_populate(). But I
> couldn't figure out how exactly the context switching ( use of
> MP_PERL_CONTEXT_STORE_OVERRIDE ) is done to make it work. I tried to
> use modperl_is_running(), but it still failed.
> 
> I have added one test in this patch, which is failing on latest mp2
> cvs snapshot.
> 
> I am just able to compile this patch. But "make test" is failing.

OK, I've polished your patch and it both compiles and your test succeeds 
too. Is that all you need? I mean test-wise, so I can start looking at the 
proposed implementation logic.

Index: src/modules/perl/modperl_env.c
===================================================================
--- src/modules/perl/modperl_env.c	(revision 123523)
+++ src/modules/perl/modperl_env.c	(working copy)
@@ -47,6 +47,26 @@
      SvTAINTED_on(*svp);
  }

+void modperl_env_hv_populate(pTHX_ apr_pool_t *p, server_rec *s,
+                             const char *key, const char *val)
+{
+    HV *hv = ENVHV;
+    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;
+    }
+
+    SvTAINTED_on(*svp);
+}
+
  static MP_INLINE
  void modperl_env_hv_delete(pTHX_ HV *hv, char *key)
  {
@@ -116,7 +136,6 @@
              continue;
          }
          modperl_env_hv_store(aTHX_ hv, &elts[i]);
-
          MP_TRACE_e(MP_FUNC, "$ENV{%s} = \"%s\";", elts[i].key, elts[i].val);
      }

@@ -141,9 +160,8 @@
              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);
  }
@@ -153,6 +171,44 @@
      "PATH", "TZ", NULL
  };

+static void modperl_env_sync_table(pTHX_ apr_table_t *table)
+{
+    U32 mg_flags;
+    int i;
+    const apr_array_header_t *array;
+    apr_table_entry_t *elts;
+
+    modperl_env_untie(mg_flags);
+
+    array = apr_table_elts(table);
+    elts  = (apr_table_entry_t *)array->elts;
+
+    for (i = 0; i < array->nelts; i++) {
+        char *val;
+
+        if (!elts[i].key || !elts[i].val) {
+            continue;
+        }
+        val = getenv(elts[i].key);
+        if (val && !apr_strnatcmp(elts[i].val, val)) {
+            apr_table_set(table, elts[i].key, val);
+        }
+    }
+
+    modperl_env_tie(mg_flags);
+}
+
+void modperl_env_sync_server(pTHX_ apr_pool_t *p, server_rec *s)
+{
+    MP_dSCFG(s);
+
+    /* Make per-server PerlSetEnv and PerlPassEnv in sync with %ENV
+     * at config time
+     */
+    modperl_env_sync_table(aTHX_ scfg->SetEnv);
+    modperl_env_sync_table(aTHX_ scfg->PassEnv);
+}
+
  void modperl_env_configure_server(pTHX_ apr_pool_t *p, server_rec *s)
  {
      MP_dSCFG(s);
@@ -578,7 +634,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,11 @@

  void modperl_env_clear(pTHX);

+void modperl_env_hv_populate(pTHX_ apr_pool_t *p, server_rec *s,
+                             const char *key, const char *val);
+
+void modperl_env_sync_server(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_server(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_server(aTHX_ parms->pool, parms->server);
+        }
          MP_PERL_CONTEXT_RESTORE;

          return error;
@@ -331,6 +337,13 @@
      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_populate(aTHX_ parms->pool, parms->server,
+                                    arg1, arg2);
+            MP_PERL_CONTEXT_RESTORE;
+        }
      }

      apr_table_setn(dcfg->SetEnv, arg1, arg2);
@@ -353,6 +366,13 @@

      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_populate(aTHX_ parms->pool, parms->server,
+                                    arg, val);
+            MP_PERL_CONTEXT_RESTORE;
+        }
          MP_TRACE_d(MP_FUNC, "arg = %s, val = %s\n", arg, val);
      }
      else {
@@ -541,6 +561,7 @@
          save_scalar(gv); /* local $0 */
          sv_setpv_mg(GvSV(gv), directive->filename);
          eval_pv(arg, FALSE);
+        modperl_env_sync_server(aTHX_ p, s);
          FREETMPS;LEAVE;
      }

@@ -626,8 +647,10 @@
   */
  MP_CMD_SRV_DECLARE(load_module)
  {
+    MP_dSCFG(parms->server);
      const char *errmsg;
-
+    MP_PERL_CONTEXT_DECLARE;
+
      MP_TRACE_d(MP_FUNC, "PerlLoadModule %s\n", arg);

      /* we must init earlier than normal */
@@ -637,6 +660,10 @@
          return errmsg;
      }

+    MP_PERL_CONTEXT_STORE_OVERRIDE(scfg->mip->parent->perl);
+    modperl_env_sync_server(aTHX_ parms->pool, parms->server);
+    MP_PERL_CONTEXT_RESTORE;
+
      return NULL;
  }

--- /dev/null	2004-12-27 14:35:25.636826264 -0500
+++ t/response/TestDirective/setupenv2.pm	2004-12-28 14:32:51.456803346 -0500
@@ -0,0 +1,68 @@
+package TestDirective::setupenv2;
+
+# This is test for checking PerlSetEnv in conf section
+
+use strict;
+use warnings FATAL => 'all';
+
+use Apache::Const -compile => qw(OK OR_ALL TAKE1);
+
+use Apache::CmdParms ();
+use Apache::Module ();
+
+my @directives = (
+    {
+     name         => 'MyEnvTest',
+     func         => __PACKAGE__ . '::MyEnvTest',
+     req_override => Apache::OR_ALL,
+     args_how     => Apache::TAKE1,
+     errmsg       => 'Env that will be stored.',
+    },
+);
+
+Apache::Module::add(__PACKAGE__, \@directives);
+
+sub MyEnvTest {
+    my($self, $parms, $arg) = @_;
+    #warn "MyEnvTest: @{[$parms->path||'']}\n\t$arg\n";
+    push @{ $self->{MyEnvTest} }, $ENV{$arg};
+
+    # store the top level srv values in the server struct as well
+    unless ($parms->path) {
+        my $srv_cfg = $self->get_config($parms->server);
+        push @{ $srv_cfg->{MyEnvTest} }, $ENV{$arg};
+    }
+}
+
+sub get_config {
+    my($self, $s) = (shift, shift);
+    Apache::Module::get_config($self, $s, @_);
+}
+
+sub handler : method {
+    my($self, $r) = @_;
+
+    $r->content_type('text/plain');
+
+    my $s = $r->server;
+    my $srv_cfg = $self->get_config($s);
+    $r->print("srv: @{ $srv_cfg->{MyEnvTest}||[] }");
+
+    return Apache::OK;
+}
+
+1;
+__END__
+
+# APACHE_TEST_CONFIG_ORDER 950
+
+<Base>
+    PerlLoadModule TestDirective::setupenv2
+    PerlSetEnv FooEnv "one"
+    MyEnvTest "FooEnv"
+    <Perl>
+    1;
+    </Perl>
+    PerlSetEnv BarEnv "two"
+    MyEnvTest "BarEnv"
+</Base>

--- /dev/null	2004-12-27 14:35:25.636826264 -0500
+++ t/directive/setupenv2.t	2004-12-28 14:32:51.432806617 -0500
@@ -0,0 +1,17 @@
+use strict;
+use warnings FATAL => 'all';
+
+use Apache::Test;
+use Apache::TestUtil;
+use Apache::TestRequest;
+
+my $url = "/TestDirective__setupenv2";
+
+plan tests => 1;
+
+{
+    my $location = "$url";
+    my $expected = "srv: one two";
+    my $received = GET_BODY $location;
+    ok t_cmp($received, $expected, "access env variable");
+}


-- 
__________________________________________________________________
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