-:    0:Source:modperl_perl.c
        -:    0:Object:modperl_perl.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:/* this module contains mod_perl small tweaks to the Perl runtime
        -:   19: * others (larger tweaks) are in their own modules, e.g. modperl_env.c
        -:   20: */
        -:   21:
        -:   22:typedef struct {
        -:   23:    const char *name;
        -:   24:    const char *sub_name;
        -:   25:    const char *core_name;
        -:   26:} modperl_perl_core_global_t;
        -:   27:
        -:   28:#define MP_PERL_CORE_GLOBAL_ENT(name) \
        -:   29:{ name, "ModPerl::Util::" name, "CORE::GLOBAL::" name }
        -:   30:
        -:   31:static modperl_perl_core_global_t MP_perl_core_global_entries[] = {
        -:   32:    MP_PERL_CORE_GLOBAL_ENT("exit"),
        -:   33:    { NULL },
        -:   34:};
        -:   35:
        -:   36:void modperl_perl_core_global_init(pTHX)
       20:   37:{
       20:   38:    modperl_perl_core_global_t *cglobals = MP_perl_core_global_entries;
        -:   39:
       20:   40:    while (cglobals->name) {
       20:   41:        GV *gv = gv_fetchpv(cglobals->core_name, TRUE, SVt_PVCV);
       20:   42:        GvCV(gv) = get_cv(cglobals->sub_name, TRUE);
       20:   43:        GvIMPORTED_CV_on(gv);
       20:   44:        cglobals++;
        -:   45:    }
        -:   46:}
        -:   47:
        -:   48:static void modperl_perl_ids_get(modperl_perl_ids_t *ids)
        4:   49:{
        4:   50:    ids->pid  = (I32)getpid();
        -:   51:#ifdef MP_MAINTAIN_PPID
        4:   52:    ids->ppid = (I32)getppid();
        -:   53:#endif
        -:   54:#ifndef WIN32
        4:   55:    ids->uid  = getuid();
        4:   56:    ids->euid = geteuid(); 
        4:   57:    ids->gid  = getgid(); 
        4:   58:    ids->gid  = getegid(); 
        -:   59:
        4:   60:    MP_TRACE_g(MP_FUNC, 
        -:   61:               "pid=%d, "
        -:   62:#ifdef MP_MAINTAIN_PPID
        -:   63:               "ppid=%d, "
        -:   64:#endif
        -:   65:               "uid=%d, euid=%d, gid=%d, egid=%d\n",
        -:   66:               (int)ids->pid,
        -:   67:#ifdef MP_MAINTAIN_PPID
        -:   68:               (int)ids->ppid,
        -:   69:#endif
        -:   70:               (int)ids->uid, (int)ids->euid,
        -:   71:               (int)ids->gid, (int)ids->egid);
        -:   72:#endif /* #ifndef WIN32 */
        -:   73:}
        -:   74:
        -:   75:static void modperl_perl_init_ids(pTHX_ modperl_perl_ids_t *ids)
       10:   76:{
       10:   77:    sv_setiv(GvSV(gv_fetchpv("$", TRUE, SVt_PV)), ids->pid);
        -:   78:
        -:   79:#ifndef WIN32
       10:   80:    PL_uid  = ids->uid;
       10:   81:    PL_euid = ids->euid;
       10:   82:    PL_gid  = ids->gid;
       10:   83:    PL_egid = ids->egid;
        -:   84:#endif
        -:   85:#ifdef MP_MAINTAIN_PPID
       10:   86:    PL_ppid = ids->ppid;
        -:   87:#endif
        -:   88:}
        -:   89:
        -:   90:
        -:   91:#ifdef USE_ITHREADS
        -:   92:
        -:   93:static apr_status_t modperl_perl_init_ids_mip(pTHX_ modperl_interp_pool_t *mip,
        -:   94:                                              void *data)
       10:   95:{
       10:   96:    modperl_perl_init_ids(aTHX_ (modperl_perl_ids_t *)data);
       10:   97:    return APR_SUCCESS;
        -:   98:}
        -:   99:
        -:  100:#endif /* USE_ITHREADS */
        -:  101:
        -:  102:void modperl_perl_init_ids_server(server_rec *s)
        4:  103:{
        4:  104:    modperl_perl_ids_t ids;
        4:  105:    modperl_perl_ids_get(&ids);
        -:  106:#ifdef USE_ITHREADS
        4:  107:     modperl_interp_mip_walk_servers(NULL, s,
        -:  108:                                     modperl_perl_init_ids_mip,
        -:  109:                                    (void*)&ids);
        -:  110:#else
        -:  111:    modperl_perl_init_ids(aTHX_ &ids);
        -:  112:#endif
        -:  113:}
        -:  114:
        -:  115:void modperl_perl_destruct(PerlInterpreter *perl)
       10:  116:{
       10:  117:    char **orig_environ = NULL;
       10:  118:    PTR_TBL_t *module_commands; 
       10:  119:    dTHXa(perl);
        -:  120:
       10:  121:    PERL_SET_CONTEXT(perl);
        -:  122:
       10:  123:    PL_perl_destruct_level = modperl_perl_destruct_level();
        -:  124:
        -:  125:#ifdef USE_ENVIRON_ARRAY
        -:  126:    /* XXX: otherwise Perl may try to free() environ multiple times
        -:  127:     * but it wasn't Perl that modified environ
        -:  128:     * at least, not if modperl is doing things right
        -:  129:     * this is a bug in Perl.
        -:  130:     */
        -:  131:#   ifdef WIN32
        -:  132:    /*
        -:  133:     * PL_origenviron = environ; doesn't work under win32 service.
        -:  134:     * we pull a different stunt here that has the same effect of
        -:  135:     * tricking perl into _not_ freeing the real 'environ' array.
        -:  136:     * instead temporarily swap with a dummy array we malloc
        -:  137:     * here which is ok to let perl free.
        -:  138:     */
        -:  139:    orig_environ = environ;
        -:  140:    environ = safemalloc(2 * sizeof(char *));
        -:  141:    environ[0] = NULL;
        -:  142:#   else
       10:  143:    PL_origenviron = environ;
        -:  144:#   endif
        -:  145:#endif
        -:  146:
       10:  147:    if (PL_endav) {
        4:  148:        modperl_perl_call_list(aTHX_ PL_endav, "END");
        -:  149:    }
        -:  150:
        -:  151:    {
       10:  152:        dTHXa(perl);
        -:  153:
       10:  154:        if ((module_commands = modperl_module_config_table_get(aTHX_ FALSE))) {
        2:  155:            modperl_svptr_table_destroy(aTHX_ module_commands);
        -:  156:        }
        -:  157:    }
        -:  158:
       10:  159:    perl_destruct(perl);
        -:  160:
        -:  161:    /* XXX: big bug in 5.6.1 fixed in 5.7.2+
        -:  162:     * XXX: try to find a workaround for 5.6.1
        -:  163:     */
        -:  164:#if defined(WIN32) && !defined(CLONEf_CLONE_HOST)
        -:  165:#   define MP_NO_PERL_FREE
        -:  166:#endif
        -:  167:
        -:  168:#ifndef MP_NO_PERL_FREE
       10:  169:    perl_free(perl);
        -:  170:#endif
        -:  171:
        -:  172:#ifdef USE_ENVIRON_ARRAY
       10:  173:    if (orig_environ) {
        -:  174:        environ = orig_environ;
        -:  175:    }
        -:  176:#endif
        -:  177:}
        -:  178:
        -:  179:#if !(PERL_REVISION == 5 && ( PERL_VERSION < 8 ||    \
        -:  180:    (PERL_VERSION == 8 && PERL_SUBVERSION == 0))) && \
        -:  181:    (defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT))
        -:  182:#define MP_NEED_HASH_SEED_FIXUP
        -:  183:#endif
        -:  184:
        -:  185:#ifdef MP_NEED_HASH_SEED_FIXUP
        -:  186:static UV   MP_init_hash_seed = 0;
        -:  187:static bool MP_init_hash_seed_set = FALSE;
        -:  188:#endif
        -:  189:
        -:  190:/* see modperl_hash_seed_set() */
        -:  191:void modperl_hash_seed_init(apr_pool_t *p) 
        8:  192:{
        -:  193:#ifdef MP_NEED_HASH_SEED_FIXUP
        8:  194:    char *s;
        -:  195:    /* check if there is a specific hash seed passed via the env var
        -:  196:     * and if that's the case -- use it */
        8:  197:    apr_status_t rv = apr_env_get(&s, "PERL_HASH_SEED", p);
        8:  198:    if (rv == APR_SUCCESS) {
    #####:  199:        if (s) {
    #####:  200:            while (isSPACE(*s)) s++;
        -:  201:        }
    #####:  202:        if (s && isDIGIT(*s)) {
    #####:  203:            MP_init_hash_seed = (UV)Atol(s); /* XXX: Atoul()? */
    #####:  204:            MP_init_hash_seed_set = TRUE;
        -:  205:        }
        -:  206:    }
        -:  207:
        -:  208:    /* calculate our own random hash seed */
        8:  209:    if (!MP_init_hash_seed_set) {
        8:  210:        apr_uuid_t *uuid = (apr_uuid_t *)apr_palloc(p, sizeof(apr_uuid_t));
        8:  211:        char buf[APR_UUID_FORMATTED_LENGTH + 1];
        8:  212:        int i;
        -:  213:
        8:  214:        apr_initialize();
        8:  215:        apr_uuid_get(uuid);
        8:  216:        apr_uuid_format(buf, uuid);
        -:  217:        /* fprintf(stderr, "UUID: %s\n", buf); */
        -:  218:
        -:  219:        /* XXX: need a better alg to convert uuid string into a seed */
      296:  220:        for (i=0; buf[i]; i++){
      288:  221:            MP_init_hash_seed += (UV)(i+1)*(buf[i]+MP_init_hash_seed);
        -:  222:        }
        -:  223:
        8:  224:        MP_init_hash_seed_set = TRUE;
        -:  225:    }
        -:  226:#endif
        -:  227:}
        -:  228:
        -:  229:/* before 5.8.1, perl was using HASH_SEED=0, starting from 5.8.1
        -:  230: * it randomizes if perl was compiled with ccflags -DUSE_HASH_SEED
        -:  231: * or -DUSE_HASH_SEED_EXPLICIT, in which case we need to tell perl
        -:  232: * to use the same seed everywhere */
        -:  233:void modperl_hash_seed_set(pTHX) 
       20:  234:{
        -:  235:#ifdef MP_NEED_HASH_SEED_FIXUP
       20:  236:    if (MP_init_hash_seed_set) {
        -:  237:#if PERL_REVISION == 5 && PERL_VERSION == 8 && PERL_SUBVERSION == 1
        -:  238:        PL_hash_seed       = MP_init_hash_seed;
        -:  239:        PL_hash_seed_set   = MP_init_hash_seed_set;
        -:  240:#else
       20:  241:        PL_rehash_seed     = MP_init_hash_seed;
       20:  242:        PL_rehash_seed_set = MP_init_hash_seed_set;
        -:  243:#endif
        -:  244:    }
        -:  245:#endif
        -:  246:}