-:    0:Source:modperl_env.c
        -:    0:Object:modperl_env.bb
        -:    1:/* Copyright 2001-2004 The Apache Software Foundation
        -:    2: *
        -:    3: * Licensed under the Apache License, Version 2.0 (the "License");
        -:    4: * you may not use this file except in compliance with the License.
        -:    5: * You may obtain a copy of the License at
        -:    6: *
        -:    7: *     http://www.apache.org/licenses/LICENSE-2.0
        -:    8: *
        -:    9: * Unless required by applicable law or agreed to in writing, software
        -:   10: * distributed under the License is distributed on an "AS IS" BASIS,
        -:   11: * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
        -:   12: * See the License for the specific language governing permissions and
        -:   13: * limitations under the License.
        -:   14: */
        -:   15:
        -:   16:#include "mod_perl.h"
        -:   17:
        -:   18:#define EnvMgObj SvMAGIC((SV*)ENVHV)->mg_ptr
        -:   19:#define EnvMgLen SvMAGIC((SV*)ENVHV)->mg_len
        -:   20:
        -:   21:/* XXX: move to utils? */
        -:   22:static unsigned long modperl_interp_address(pTHX)
    #####:   23:{
        -:   24:#ifdef USE_ITHREADS
    #####:   25:    return (unsigned long)aTHX;
        -:   26:#else
        -:   27:    return (unsigned long)0; /* just one interpreter */
        -:   28:#endif
        -:   29:}
        -:   30:
        -:   31:static MP_INLINE
        -:   32:void modperl_env_hv_store(pTHX_ HV *hv, apr_table_entry_t *elt)
     6120:   33:{
     6120:   34:    I32 klen = strlen(elt->key);
     6120:   35:    SV **svp = hv_fetch(hv, elt->key, klen, FALSE);
        -:   36:
     6120:   37:    if (svp) {
     2268:   38:        sv_setpv(*svp, elt->val);
        -:   39:    }
        -:   40:    else {
     3852:   41:        SV *sv = newSVpv(elt->val, 0);
     3852:   42:        hv_store(hv, elt->key, klen, sv, FALSE);
     3852:   43:        modperl_envelem_tie(sv, elt->key, klen);
     3852:   44:        svp = &sv;
        -:   45:    }
        -:   46:
     6120:   47:    SvTAINTED_on(*svp);
        -:   48:}
        -:   49:
        -:   50:static MP_INLINE
        -:   51:void modperl_env_hv_delete(pTHX_ HV *hv, char *key)
     3876:   52:{
     3876:   53:    I32 klen = strlen(key);
     3876:   54:    if (hv_exists(hv, key, klen)) {
     1169:   55:        hv_delete(hv, key, strlen(key), G_DISCARD);
        -:   56:    }
        -:   57:}
        -:   58:
        -:   59:typedef struct {
        -:   60:    const char *key;
        -:   61:    I32 klen;
        -:   62:    const char *val;
        -:   63:    I32 vlen;
        -:   64:    U32 hash;
        -:   65:} modperl_env_ent_t;
        -:   66:
        -:   67:#define MP_ENV_ENT(k,v) \
        -:   68:{ k, MP_SSTRLEN(k), v, MP_SSTRLEN(v), 0 }
        -:   69:
        -:   70:static modperl_env_ent_t MP_env_const_vars[] = {
        -:   71:    MP_ENV_ENT("MOD_PERL", MP_VERSION_STRING),
        -:   72:    { NULL }
        -:   73:};
        -:   74:
        -:   75:void modperl_env_hash_keys(pTHX)
        8:   76:{
        8:   77:    modperl_env_ent_t *ent = MP_env_const_vars;
        -:   78:
        8:   79:    while (ent->key) {
        8:   80:        PERL_HASH(ent->hash, ent->key, ent->klen);
        8:   81:        MP_TRACE_e(MP_FUNC, "[0x%lx] PERL_HASH: %s (len: %d)",
        -:   82:                   modperl_interp_address(aTHX), ent->key, ent->klen);
        8:   83:        ent++;
        -:   84:    }
        -:   85:}
        -:   86:
        -:   87:void modperl_env_clear(pTHX)
       20:   88:{
       20:   89:    HV *hv = ENVHV;
       20:   90:    U32 mg_flags;
        -:   91:
       20:   92:    modperl_env_untie(mg_flags);
        -:   93:
       20:   94:    MP_TRACE_e(MP_FUNC, "[0x%lx] %%ENV = ();", modperl_interp_address(aTHX));
        -:   95:
       20:   96:    hv_clear(hv);
        -:   97:
       20:   98:    modperl_env_tie(mg_flags);
        -:   99:}
        -:  100:
        -:  101:static void modperl_env_table_populate(pTHX_ apr_table_t *table)
     1291:  102:{
     1291:  103:    HV *hv = ENVHV;
     1291:  104:    U32 mg_flags;
     1291:  105:    int i;
     1291:  106:    const apr_array_header_t *array;
     1291:  107:    apr_table_entry_t *elts;
        -:  108:
     1291:  109:    modperl_env_untie(mg_flags);
        -:  110:
     1291:  111:    array = apr_table_elts(table);
     1291:  112:    elts  = (apr_table_entry_t *)array->elts;
        -:  113:
     7411:  114:    for (i = 0; i < array->nelts; i++) {
     6120:  115:        if (!elts[i].key || !elts[i].val) {
     6120:  116:            continue;
        -:  117:        }
     6120:  118:        modperl_env_hv_store(aTHX_ hv, &elts[i]);
        -:  119:
     6120:  120:        MP_TRACE_e(MP_FUNC, "$ENV{%s} = \"%s\";", elts[i].key, elts[i].val);
        -:  121:    }    
        -:  122:
     1291:  123:    modperl_env_tie(mg_flags);
        -:  124:}
        -:  125:
        -:  126:static void modperl_env_table_unpopulate(pTHX_ apr_table_t *table)
      153:  127:{
      153:  128:    HV *hv = ENVHV;
      153:  129:    U32 mg_flags;
      153:  130:    int i;
      153:  131:    const apr_array_header_t *array;
      153:  132:    apr_table_entry_t *elts;
        -:  133:
      153:  134:    modperl_env_untie(mg_flags);
        -:  135:
      153:  136:    array = apr_table_elts(table);
      153:  137:    elts  = (apr_table_entry_t *)array->elts;
        -:  138:
     4029:  139:    for (i = 0; i < array->nelts; i++) {
     3876:  140:        if (!elts[i].key) {
     3876:  141:            continue;
        -:  142:        }
     3876:  143:        modperl_env_hv_delete(aTHX_ hv, elts[i].key);
        -:  144:
     3876:  145:        MP_TRACE_e(MP_FUNC, "delete $ENV{%s};", elts[i].key);
        -:  146:    }    
        -:  147:
      153:  148:    modperl_env_tie(mg_flags);
        -:  149:}
        -:  150:
        -:  151:/* list of environment variables to pass by default */
        -:  152:static const char *MP_env_pass_defaults[] = {
        -:  153:    "PATH", "TZ", NULL
        -:  154:};
        -:  155:
        -:  156:void modperl_env_configure_server(pTHX_ apr_pool_t *p, server_rec *s)
       20:  157:{
       20:  158:    MP_dSCFG(s);
       20:  159:    int i = 0;
        -:  160:
        -:  161:    /* make per-server PerlSetEnv and PerlPassEnv entries visible
        -:  162:     * to %ENV at config time
        -:  163:     */
        -:  164:
       60:  165:    for (i=0; MP_env_pass_defaults[i]; i++) {
       40:  166:        const char *key = MP_env_pass_defaults[i];
       40:  167:        char *val;
        -:  168:
       40:  169:        if (apr_table_get(scfg->SetEnv, key) ||
        -:  170:            apr_table_get(scfg->PassEnv, key))
        -:  171:        {
       40:  172:            continue; /* already configured */
        -:  173:        }
        -:  174:
       40:  175:        if ((val = getenv(key))) {
       20:  176:            apr_table_set(scfg->PassEnv, key, val);
        -:  177:        }
        -:  178:    }
        -:  179:
       20:  180:    MP_TRACE_e(MP_FUNC, "\n\t[%s/0x%lx/%s]"
        -:  181:               "\n\t@ENV{keys scfg->SetEnv} = values scfg->SetEnv;",
        -:  182:               modperl_pid_tid(p), modperl_interp_address(aTHX),
        -:  183:               modperl_server_desc(s, p));
       20:  184:    modperl_env_table_populate(aTHX_ scfg->SetEnv);
        -:  185:
       20:  186:    MP_TRACE_e(MP_FUNC, "\n\t[%s/0x%lx/%s]"
        -:  187:               "\n\t@ENV{keys scfg->PassEnv} = values scfg->PassEnv;",
        -:  188:               modperl_pid_tid(p), modperl_interp_address(aTHX),
        -:  189:               modperl_server_desc(s, p));
       20:  190:    modperl_env_table_populate(aTHX_ scfg->PassEnv);
        -:  191:}
        -:  192:
        -:  193:#define overlay_subprocess_env(r, tab) \
        -:  194:    r->subprocess_env = apr_table_overlay(r->pool, \
        -:  195:                                          r->subprocess_env, \
        -:  196:                                          tab)
        -:  197:
        -:  198:void modperl_env_configure_request_dir(pTHX_ request_rec *r)
      416:  199:{
      416:  200:    MP_dRCFG;
      416:  201:    MP_dDCFG;
        -:  202:
        -:  203:    /* populate %ENV and r->subprocess_env with per-directory 
        -:  204:     * PerlSetEnv entries.
        -:  205:     *
        -:  206:     * note that per-server PerlSetEnv entries, as well as
        -:  207:     * PerlPassEnv entries (which are only per-server), are added
        -:  208:     * to %ENV and r->subprocess_env via modperl_env_configure_request_srv
        -:  209:     */
        -:  210:
      416:  211:    if (!apr_is_empty_table(dcfg->SetEnv)) {
      309:  212:        apr_table_t *setenv_copy;
        -:  213:
        -:  214:        /* add per-directory PerlSetEnv entries to %ENV
        -:  215:         * collisions with per-server PerlSetEnv entries are 
        -:  216:         * resolved via the nature of a Perl hash
        -:  217:         */
      309:  218:        MP_TRACE_e(MP_FUNC, "\n\t[%s/0x%lx/%s]"
        -:  219:                   "\n\t@ENV{keys dcfg->SetEnv} = values dcfg->SetEnv;",
        -:  220:                   modperl_pid_tid(r->pool), modperl_interp_address(aTHX),
        -:  221:                   modperl_server_desc(r->server, r->pool));
      309:  222:        modperl_env_table_populate(aTHX_ dcfg->SetEnv);
        -:  223:
        -:  224:        /* make sure the entries are in the subprocess_env table as well.
        -:  225:         * we need to use apr_table_overlap (not apr_table_overlay) because
        -:  226:         * r->subprocess_env might have per-server PerlSetEnv entries in it
        -:  227:         * and using apr_table_overlay would generate duplicate entries.
        -:  228:         * in order to use apr_table_overlap, though, we need to copy the
        -:  229:         * the dcfg table so that pool requirements are satisfied */
        -:  230:        
      309:  231:        setenv_copy = apr_table_copy(r->pool, dcfg->SetEnv);
      309:  232:        apr_table_overlap(r->subprocess_env, setenv_copy, APR_OVERLAP_TABLES_SET);
        -:  233:    }
        -:  234:
      416:  235:    MpReqPERL_SET_ENV_DIR_On(rcfg);
        -:  236:}
        -:  237:
        -:  238:void modperl_env_configure_request_srv(pTHX_ request_rec *r)
      447:  239:{
      447:  240:    MP_dRCFG;
      447:  241:    MP_dSCFG(r->server);
        -:  242:
        -:  243:    /* populate %ENV and r->subprocess_env with per-server PerlSetEnv 
        -:  244:     * and PerlPassEnv entries.  
        -:  245:     *
        -:  246:     * although both are setup in %ENV in modperl_request_configure_server
        -:  247:     * %ENV will be reset via modperl_env_request_unpopulate.
        -:  248:     */
        -:  249:
      447:  250:    if (!apr_is_empty_table(scfg->SetEnv)) {
      339:  251:        MP_TRACE_e(MP_FUNC, "\n\t[%s/0x%lx/%s]"
        -:  252:                   "\n\t@ENV{keys scfg->SetEnv} = values scfg->SetEnv;",
        -:  253:                   modperl_pid_tid(r->pool), modperl_interp_address(aTHX),
        -:  254:                   modperl_server_desc(r->server, r->pool));
      339:  255:        modperl_env_table_populate(aTHX_ scfg->SetEnv);
        -:  256:
      339:  257:        overlay_subprocess_env(r, scfg->SetEnv);
        -:  258:    }
        -:  259:
      447:  260:    if (!apr_is_empty_table(scfg->PassEnv)) {
      447:  261:        MP_TRACE_e(MP_FUNC, "\n\t[%s/0x%lx/%s]"
        -:  262:                   "\n\t@ENV{keys scfg->PassEnv} = values scfg->PassEnv;",
        -:  263:                   modperl_pid_tid(r->pool), modperl_interp_address(aTHX),
        -:  264:                   modperl_server_desc(r->server, r->pool));
      447:  265:        modperl_env_table_populate(aTHX_ scfg->PassEnv);
        -:  266:
      447:  267:        overlay_subprocess_env(r, scfg->PassEnv);
        -:  268:    }
        -:  269:
      447:  270:    MpReqPERL_SET_ENV_SRV_On(rcfg);
        -:  271:}
        -:  272:
        -:  273:void modperl_env_default_populate(pTHX)
       20:  274:{
       20:  275:    modperl_env_ent_t *ent = MP_env_const_vars;
       20:  276:    HV *hv = ENVHV;
       20:  277:    U32 mg_flags;
        -:  278:
       20:  279:    modperl_env_untie(mg_flags);
        -:  280:
       20:  281:    while (ent->key) {
       20:  282:        SV *sv = newSVpvn(ent->val, ent->vlen);
       20:  283:        hv_store(hv, ent->key, ent->klen,
        -:  284:                 sv, ent->hash);
       20:  285:        MP_TRACE_e(MP_FUNC, "$ENV{%s} = \"%s\";", ent->key, ent->val);
       20:  286:        modperl_envelem_tie(sv, ent->key, ent->klen);
       20:  287:        ent++;
        -:  288:    }
        -:  289:
       20:  290:    modperl_env_tie(mg_flags);
        -:  291:}
        -:  292:
        -:  293:void modperl_env_request_populate(pTHX_ request_rec *r)
      156:  294:{
      156:  295:    MP_dRCFG;
        -:  296: 
        -:  297:    /* this is called under the following conditions
        -:  298:     *   - if PerlOptions +SetupEnv
        -:  299:     *   - if $r->subprocess_env() is called in a void context with no args
        -:  300:     *
        -:  301:     * normally, %ENV is only populated once per request (if at all) -
        -:  302:     * just prior to content generation if +SetupEnv.
        -:  303:     *
        -:  304:     * however, in the $r->subprocess_env() case it will be called 
        -:  305:     * more than once - once for each void call, and once again just
        -:  306:     * prior to content generation.  while costly, the multiple
        -:  307:     * passes are required, otherwise void calls would prohibit later
        -:  308:     * phases from populating %ENV with new subprocess_env table entries
        -:  309:     */
        -:  310:
      156:  311:    MP_TRACE_e(MP_FUNC, "\n\t[%s/0x%lx/%s%s]"
        -:  312:               "\n\t@ENV{keys r->subprocess_env} = values r->subprocess_env;",
        -:  313:               modperl_pid_tid(r->pool), modperl_interp_address(aTHX),
        -:  314:               modperl_server_desc(r->server, r->pool), r->uri);
        -:  315:
        -:  316:    /* we can eliminate some of the cost by only doing CGI variables once
        -:  317:     * per-request no matter how many times $r->subprocess_env() is called
        -:  318:     */
      156:  319:    if (! MpReqSETUP_ENV(rcfg)) {
        -:  320:
      153:  321:        ap_add_common_vars(r);
      153:  322:        ap_add_cgi_vars(r);
        -:  323:
        -:  324:    }
        -:  325:
      156:  326:    modperl_env_table_populate(aTHX_ r->subprocess_env);
        -:  327:
        -:  328:    /* don't set up CGI variables again this request.
        -:  329:     * this also triggers modperl_env_request_unpopulate, which
        -:  330:     * resets %ENV between requests - see modperl_config_request_cleanup 
        -:  331:     */
      156:  332:    MpReqSETUP_ENV_On(rcfg);
        -:  333:}
        -:  334:
        -:  335:void modperl_env_request_unpopulate(pTHX_ request_rec *r)
      153:  336:{
      153:  337:    MP_dRCFG;
        -:  338:
        -:  339:    /* unset only once */
      153:  340:    if (!MpReqSETUP_ENV(rcfg)) {
      153:  341:        return;
        -:  342:    }
        -:  343:    
      153:  344:    MP_TRACE_e(MP_FUNC,
        -:  345:               "\n\t[%s/0x%lx/%s%s]\n\tdelete @ENV{keys r->subprocess_env};",
        -:  346:               modperl_pid_tid(r->pool), modperl_interp_address(aTHX),
        -:  347:               modperl_server_desc(r->server, r->pool), r->uri);
      153:  348:    modperl_env_table_unpopulate(aTHX_ r->subprocess_env);
        -:  349:
      153:  350:    MpReqSETUP_ENV_Off(rcfg);
        -:  351:}
        -:  352:
        -:  353:void modperl_env_request_tie(pTHX_ request_rec *r)
      127:  354:{
      127:  355:    EnvMgObj = (char *)r;
      127:  356:    EnvMgLen = -1;
        -:  357:
        -:  358:#ifdef MP_PERL_HV_GMAGICAL_AWARE
        -:  359:    MP_TRACE_e(MP_FUNC, "[%s/0x%lx] tie %%ENV, $r\n\t (%s%s)",
        -:  360:               modperl_pid_tid(r->pool), modperl_interp_address(aTHX),
        -:  361:               modperl_server_desc(r->server, r->pool), r->uri);
        -:  362:    SvGMAGICAL_on((SV*)ENVHV);
        -:  363:#endif
        -:  364:}
        -:  365:
        -:  366:void modperl_env_request_untie(pTHX_ request_rec *r)
      127:  367:{
      127:  368:    EnvMgObj = NULL;
        -:  369:
        -:  370:#ifdef MP_PERL_HV_GMAGICAL_AWARE
        -:  371:    MP_TRACE_e(MP_FUNC, "[%s/0x%lx] untie %%ENV; # from r\n\t (%s%s)",
        -:  372:               modperl_pid_tid(r->pool), modperl_interp_address(aTHX),
        -:  373:               modperl_server_desc(r->server, r->pool), r->uri);
        -:  374:    SvGMAGICAL_off((SV*)ENVHV);
        -:  375:#endif
        -:  376:}
        -:  377:
        -:  378:/* to store the original virtual tables
        -:  379: * these are global, not per-interpreter
        -:  380: */
        -:  381:static MGVTBL MP_PERL_vtbl_env;
        -:  382:static MGVTBL MP_PERL_vtbl_envelem;
        -:  383:
        -:  384:#define MP_PL_vtbl_call(name, meth) \
        -:  385:    MP_PERL_vtbl_##name.svt_##meth(aTHX_ sv, mg)
        -:  386:
        -:  387:#define MP_dENV_KEY \
        -:  388:    STRLEN klen; \
        -:  389:    const char *key = (const char *)MgPV(mg,klen)
        -:  390:
        -:  391:#define MP_dENV_VAL \
        -:  392:    STRLEN vlen; \
        -:  393:    const char *val = (const char *)SvPV(sv,vlen)
        -:  394:
        -:  395:/*
        -:  396: * XXX: what we do here might change:
        -:  397: *      - make it optional for %ENV to be tied to r->subprocess_env
        -:  398: *      - make it possible to modify environ
        -:  399: *      - we could allow modification of environ if mpm isn't threaded
        -:  400: *      - we could allow modification of environ if variable isn't a CGI
        -:  401: *        variable (still could cause problems)
        -:  402: */
        -:  403:/*
        -:  404: * problems we are trying to solve:
        -:  405: *      - environ is shared between threads
        -:  406: *          + Perl does not serialize access to environ
        -:  407: *          + even if it did, CGI variables cannot be shared between threads!
        -:  408: * problems we create by trying to solve above problems:
        -:  409: *      - a forked process will not inherit the current %ENV
        -:  410: *      - C libraries might rely on environ, e.g. DBD::Oracle
        -:  411: */
        -:  412:static int modperl_env_magic_set_all(pTHX_ SV *sv, MAGIC *mg)
        2:  413:{
        2:  414:    request_rec *r = (request_rec *)EnvMgObj;
        -:  415:
        2:  416:    if (r) {
        2:  417:        if (PL_localizing) {
        -:  418:            /* local %ENV = (FOO => 'bar', BIZ => 'baz') */
        2:  419:            HE *entry;
        2:  420:            STRLEN n_a;
        -:  421:
        2:  422:            hv_iterinit((HV*)sv);
        2:  423:            while ((entry = hv_iternext((HV*)sv))) {
       32:  424:                I32 keylen;
       32:  425:                apr_table_set(r->subprocess_env,
        -:  426:                              hv_iterkey(entry, &keylen),
        -:  427:                              SvPV(hv_iterval((HV*)sv, entry), n_a));
       32:  428:                MP_TRACE_e(MP_FUNC, "[%s/0x%lx] localizing: %s => %s",
        -:  429:                           modperl_pid_tid(r->pool),
        -:  430:                           modperl_interp_address(aTHX),
        -:  431:                           hv_iterkey(entry, &keylen),
        -:  432:                           SvPV(hv_iterval((HV*)sv, entry), n_a));
        -:  433:            }
        -:  434:        }
        -:  435:    }
        -:  436:    else {
        -:  437:#ifdef MP_TRACE
    #####:  438:        HE *entry;
    #####:  439:        STRLEN n_a;
        -:  440:        
    #####:  441:        MP_TRACE_e(MP_FUNC,
        -:  442:                   "\n\t[%lu/0x%lx] populating %%ENV:",
        -:  443:                   (unsigned long)getpid(), modperl_interp_address(aTHX));
        -:  444:
    #####:  445:        hv_iterinit((HV*)sv);
        -:  446:
    #####:  447:        while ((entry = hv_iternext((HV*)sv))) {
    #####:  448:                I32 keylen;
    #####:  449:                MP_TRACE_e(MP_FUNC, "$ENV{%s} = \"%s\";",
        -:  450:                           modperl_pid_tid(r->pool),
        -:  451:                           modperl_interp_address(aTHX),
        -:  452:                           hv_iterkey(entry, &keylen),
        -:  453:                           SvPV(hv_iterval((HV*)sv, entry), n_a));
        -:  454:            }
        -:  455:#endif
    #####:  456:        return MP_PL_vtbl_call(env, set);
        -:  457:    }
        -:  458:
        2:  459:    return 0;
        -:  460:}
        -:  461:
        -:  462:static int modperl_env_magic_clear_all(pTHX_ SV *sv, MAGIC *mg)
        1:  463:{
        1:  464:    request_rec *r = (request_rec *)EnvMgObj;
        -:  465:
        1:  466:    if (r) {
        1:  467:        apr_table_clear(r->subprocess_env);
        1:  468:        MP_TRACE_e(MP_FUNC,
        -:  469:                   "[%s/0x%lx] clearing all magic off r->subprocess_env",
        -:  470:                   modperl_pid_tid(r->pool), modperl_interp_address(aTHX));
        -:  471:    }
        -:  472:    else {
    #####:  473:        MP_TRACE_e(MP_FUNC,
        -:  474:                   "[%s/0x%lx] %%ENV = ();",
        -:  475:                   modperl_pid_tid(r->pool), modperl_interp_address(aTHX));
    #####:  476:        return MP_PL_vtbl_call(env, clear);
        -:  477:    }
        -:  478:
        1:  479:    return 0;
        -:  480:}
        -:  481:
        -:  482:static int modperl_env_magic_set(pTHX_ SV *sv, MAGIC *mg)
     1202:  483:{
     1202:  484:    request_rec *r = (request_rec *)EnvMgObj;
        -:  485:
     1202:  486:    if (r) {
       11:  487:        MP_dENV_KEY;
       11:  488:        MP_dENV_VAL;
       11:  489:        apr_table_set(r->subprocess_env, key, val);
       11:  490:        MP_TRACE_e(MP_FUNC, "[%s/0x%lx] r->subprocess_env set: %s => %s",
        -:  491:                   modperl_pid_tid(r->pool),
        -:  492:                   modperl_interp_address(aTHX), key, val);
        -:  493:    }
        -:  494:    else {
        -:  495:#ifdef MP_TRACE
     1191:  496:        MP_dENV_KEY;
     1191:  497:        MP_dENV_VAL;
     1191:  498:        MP_TRACE_e(MP_FUNC,
        -:  499:                   "[%lu/0x%lx] $ENV{%s} = \"%s\";",
        -:  500:                   (unsigned long)getpid(),
        -:  501:                   modperl_interp_address(aTHX), key, val);
        -:  502:#endif
     1191:  503:        return MP_PL_vtbl_call(envelem, set);
        -:  504:    }
        -:  505:
       11:  506:    return 0;
        -:  507:}
        -:  508:
        -:  509:static int modperl_env_magic_clear(pTHX_ SV *sv, MAGIC *mg)
       61:  510:{
       61:  511:    request_rec *r = (request_rec *)EnvMgObj;
        -:  512:
       61:  513:    if (r) {
       41:  514:        MP_dENV_KEY;
       41:  515:        apr_table_unset(r->subprocess_env, key);
       41:  516:        MP_TRACE_e(MP_FUNC, "[%s/0x%lx] r->subprocess_env unset: %s",
        -:  517:                   modperl_pid_tid(r->pool),
        -:  518:                   modperl_interp_address(aTHX), key);
        -:  519:    }
        -:  520:    else {
        -:  521:#ifdef MP_TRACE
       20:  522:        MP_dENV_KEY;
       20:  523:        MP_TRACE_e(MP_FUNC, "[%lu/0x%lx] delete $ENV{%s};",
        -:  524:                   (unsigned long)getpid(),
        -:  525:                   modperl_interp_address(aTHX), key);
        -:  526:#endif
       20:  527:        return MP_PL_vtbl_call(envelem, clear);
        -:  528:    }
        -:  529:
       41:  530:    return 0;
        -:  531:}
        -:  532:
        -:  533:#ifdef MP_PERL_HV_GMAGICAL_AWARE
        -:  534:static int modperl_env_magic_get(pTHX_ SV *sv, MAGIC *mg)
        -:  535:{
        -:  536:    request_rec *r = (request_rec *)EnvMgObj;
        -:  537:
        -:  538:    if (r) {
        -:  539:        MP_dENV_KEY;
        -:  540:        const char *val;
        -:  541:
        -:  542:        if ((val = apr_table_get(r->subprocess_env, key))) {
        -:  543:            sv_setpv(sv, val);
        -:  544:            MP_TRACE_e(MP_FUNC,
        -:  545:                       "[%s/0x%lx] r->subprocess_env get: %s => %s",
        -:  546:                       modperl_pid_tid(r->pool),
        -:  547:                       modperl_interp_address(aTHX), key, val);
        -:  548:        }
        -:  549:        else {
        -:  550:            sv_setsv(sv, &PL_sv_undef);
        -:  551:            MP_TRACE_e(MP_FUNC,
        -:  552:                       "[%s/0x%lx] r->subprocess_env get: %s => undef",
        -:  553:                       modperl_pid_tid(r->pool),
        -:  554:                       modperl_interp_address(aTHX), key);
        -:  555:        }
        -:  556:    }
        -:  557:    else {
        -:  558:        /* there is no svt_get in PL_vtbl_envelem */
        -:  559:#ifdef MP_TRACE
        -:  560:        MP_dENV_KEY;
        -:  561:        MP_TRACE_e(MP_FUNC,
        -:  562:                   "[%lu/0x%lx] there is no svt_get in PL_vtbl_envelem: %s",
        -:  563:                   (unsigned long)getpid(),
        -:  564:                   modperl_interp_address(aTHX), key);
        -:  565:#endif
        -:  566:    }
        -:  567:
        -:  568:    return 0;
        -:  569:}
        -:  570:#endif
        -:  571:
        -:  572:/* override %ENV virtual tables with our own */
        -:  573:static MGVTBL MP_vtbl_env = {
        -:  574:    0,
        -:  575:    MEMBER_TO_FPTR(modperl_env_magic_set_all),
        -:  576:    0,
        -:  577:    MEMBER_TO_FPTR(modperl_env_magic_clear_all),
        -:  578:    0
        -:  579:};
        -:  580:
        -:  581:static MGVTBL MP_vtbl_envelem =	{
        -:  582:    0,
        -:  583:    MEMBER_TO_FPTR(modperl_env_magic_set),
        -:  584:    0,
        -:  585:    MEMBER_TO_FPTR(modperl_env_magic_clear),
        -:  586:    0
        -:  587:};
        -:  588:
        -:  589:void modperl_env_init(void)
        8:  590:{
        -:  591:    /* save originals */
        8:  592:    StructCopy(&PL_vtbl_env, &MP_PERL_vtbl_env, MGVTBL);
        8:  593:    StructCopy(&PL_vtbl_envelem, &MP_PERL_vtbl_envelem, MGVTBL);
        -:  594:
        -:  595:    /* replace with our versions */
        8:  596:    StructCopy(&MP_vtbl_env, &PL_vtbl_env, MGVTBL);
        8:  597:    StructCopy(&MP_vtbl_envelem, &PL_vtbl_envelem, MGVTBL);
        -:  598:}
        -:  599:
        -:  600:void modperl_env_unload(void)
        4:  601:{
        -:  602:    /* restore originals */
        4:  603:    StructCopy(&MP_PERL_vtbl_env, &PL_vtbl_env, MGVTBL);
        4:  604:    StructCopy(&MP_PERL_vtbl_envelem, &PL_vtbl_envelem, MGVTBL);
        -:  605:}