perl-dev mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From Pratik <pratikn...@gmail.com>
Subject Re: [mp2 bug] Perl*Env issues
Date Wed, 29 Dec 2004 07:34:07 GMT
Yup. The patch is working nice and solving all the issues related to
PerlPassEnv & PerlSetEnv.

Thanks,
Pratik


On Tue, 28 Dec 2004 15:34:11 -0500, Stas Bekman <stas@stason.org> wrote:
> 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
> 


-- 


http://pratik.syslock.org

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


Mime
View raw message