-:    0:Source:mod_perl.c
        -:    0:Object:mod_perl.bb
        -:    1:/* Copyright 2000-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:/* make sure that mod_perl won't try to start itself, while it's
        -:   19: * already starting. If the flag's value is 1 * it's still starting,
        -:   20: * when it's 2 it is running */
        -:   21:static int MP_init_status = 0;
        -:   22:
        -:   23:#define MP_IS_NOT_RUNNING (MP_init_status == 0 ? 1 : 0)
        -:   24:#define MP_IS_STARTING    (MP_init_status == 1 ? 1 : 0)
        -:   25:#define MP_IS_RUNNING     (MP_init_status == 2 ? 1 : 0)
        -:   26:
        -:   27:#ifndef USE_ITHREADS
        -:   28:static apr_status_t modperl_shutdown(void *data)
        -:   29:{
        -:   30:    modperl_cleanup_data_t *cdata = (modperl_cleanup_data_t *)data;
        -:   31:    PerlInterpreter *perl = (PerlInterpreter *)cdata->data;
        -:   32:    void **handles;
        -:   33:
        -:   34:    handles = modperl_xs_dl_handles_get(aTHX);
        -:   35:
        -:   36:    MP_TRACE_i(MP_FUNC, "destroying interpreter=0x%lx\n",
        -:   37:               (unsigned long)perl);
        -:   38:
        -:   39:    modperl_perl_destruct(perl);
        -:   40:
        -:   41:    modperl_xs_dl_handles_close(handles);
        -:   42:
        -:   43:    return APR_SUCCESS;
        -:   44:}
        -:   45:#endif
        -:   46:
        -:   47:static const char *MP_xs_loaders[] = {
        -:   48:    "Apache", "APR", NULL,
        -:   49:};
        -:   50:
        -:   51:#define MP_xs_loader_name "%s::XSLoader::BOOTSTRAP"
        -:   52:
        -:   53:/* ugly hack to have access to startup pool and server during xs_init */
        -:   54:static struct {
        -:   55:    apr_pool_t *p;
        -:   56:    server_rec *s;
        -:   57:} MP_boot_data = {NULL,NULL};
        -:   58:
        -:   59:#define MP_boot_data_set(pool, server) \
        -:   60:    MP_boot_data.p = pool; \
        -:   61:    MP_boot_data.s = server
        -:   62:
        -:   63:#define MP_dBOOT_DATA \
        -:   64:    apr_pool_t *p = MP_boot_data.p; \
        -:   65:    server_rec *s = MP_boot_data.s
        -:   66:
        -:   67:static void modperl_boot(pTHX_ void *data)
       20:   68:{
       20:   69:    MP_dBOOT_DATA;
       20:   70:    int i;
        -:   71:
       20:   72:    modperl_env_clear(aTHX);
        -:   73:
       20:   74:    modperl_env_default_populate(aTHX);
        -:   75:
       20:   76:    modperl_env_configure_server(aTHX_ p, s);
        -:   77:
       20:   78:    modperl_perl_core_global_init(aTHX);
        -:   79:
       60:   80:    for (i=0; MP_xs_loaders[i]; i++) {
       40:   81:        char *name = Perl_form(aTHX_ MP_xs_loader_name, MP_xs_loaders[i]);
       40:   82:        newCONSTSUB(PL_defstash, name, newSViv(1));
        -:   83:    }
        -:   84:
        -:   85:    /* outside mod_perl this is done by ModPerl::Const.xs */
       20:   86:    newXS("ModPerl::Const::compile", XS_modperl_const_compile, __FILE__);
        -:   87:
        -:   88:    /* make sure DynaLoader is loaded before XSLoader
        -:   89:     * - to workaround bug in 5.6.1 that can trigger a segv
        -:   90:     * when using modperl as a dso
        -:   91:     * - also needed when <Perl> sections are loaded from +Parent vhost
        -:   92:     */
       20:   93:    modperl_require_module(aTHX_ "DynaLoader", FALSE);
        -:   94:
       20:   95:    IoFLUSH_on(PL_stderrgv); /* unbuffer STDERR */
        -:   96:}
        -:   97:
        -:   98:static void modperl_xs_init(pTHX)
       20:   99:{
       20:  100:    xs_init(aTHX); /* see modperl_xsinit.c */
        -:  101:
        -:  102:    /* XXX: in 5.7.2+ we can call the body of modperl_boot here
        -:  103:     * but in 5.6.1 the Perl runtime is not properly setup yet
        -:  104:     * so we have to pull this stunt to delay
        -:  105:     */
       20:  106:    SAVEDESTRUCTOR_X(modperl_boot, 0);
        -:  107:}
        -:  108:
        -:  109:/*
        -:  110: * the "server_pool" is a subpool of the parent pool (aka "pconf")
        -:  111: * this is where we register the cleanups that teardown the interpreter.
        -:  112: * the parent process will run the cleanups since server_pool is a subpool
        -:  113: * of pconf.  we manually clear the server_pool to run cleanups in the
        -:  114: * child processes
        -:  115: */
        -:  116:static apr_pool_t *server_pool = NULL;
        -:  117:
        -:  118:apr_pool_t *modperl_server_pool(void)
       20:  119:{
       20:  120:    return server_pool;
        -:  121:}
        -:  122:
        -:  123:static void set_taint_var(PerlInterpreter *perl)
       20:  124:{
       20:  125:    dTHXa(perl);
        -:  126:
        -:  127:/* 5.7.3+ has a built-in special ${^TAINT}, backport it to 5.6.0+ */
        -:  128:#if PERL_REVISION == 5 && \
        -:  129:    (PERL_VERSION == 6 || (PERL_VERSION == 7 && PERL_SUBVERSION < 3))
        -:  130:    {
        -:  131:        GV *gv = gv_fetchpv("\024AINT", GV_ADDMULTI, SVt_IV);
        -:  132:        sv_setiv(GvSV(gv), PL_tainting);
        -:  133:        SvREADONLY_on(GvSV(gv));
        -:  134:    }
        -:  135:#endif /* perl v < 5.7.3 */
        -:  136:
        -:  137:#ifdef MP_COMPAT_1X
        -:  138:    {
       20:  139:        GV *gv = gv_fetchpv("Apache::__T", GV_ADDMULTI, SVt_PV);
       20:  140:        sv_setiv(GvSV(gv), PL_tainting);
       20:  141:        SvREADONLY_on(GvSV(gv));
        -:  142:    }
        -:  143:#endif /* MP_COMPAT_1X */
        -:  144:    
        -:  145:}
        -:  146:
        -:  147:PerlInterpreter *modperl_startup(server_rec *s, apr_pool_t *p)
       28:  148:{
       28:  149:    AV *endav;
       28:  150:    dTHXa(NULL);
       28:  151:    MP_dSCFG(s);
       28:  152:    PerlInterpreter *perl;
       28:  153:    int status;
       28:  154:    char **argv;
       28:  155:    int argc;
        -:  156:#ifndef USE_ITHREADS
        -:  157:    modperl_cleanup_data_t *cdata;
        -:  158:#endif
        -:  159:
        -:  160:    /* ensure that we start the base server's perl, before vhost's
        -:  161:     * one, if modperl_startup was called by vhost before the former
        -:  162:     * was started */
       28:  163:    if (MP_init_status != 2) {
        8:  164:        server_rec *base_server = modperl_global_get_server_rec();
        8:  165:        PerlInterpreter *base_perl;
        -:  166:        
        8:  167:        MP_init_status = 2; /* calls itself, so set the flag early */
        8:  168:        base_perl = modperl_startup(base_server, p);
        -:  169:        
        8:  170:        if (base_server == s ) {
        8:  171:            return base_perl;
        -:  172:        }
        -:  173:    }
        -:  174:
        -:  175:#ifdef MP_TRACE
        -:  176:    {
       20:  177:        server_rec *base_server = modperl_global_get_server_rec();
       20:  178:        const char *desc = modperl_server_desc(s, p);
       20:  179:        if (base_server == s) {        
        8:  180:            MP_TRACE_i(MP_FUNC,
        -:  181:                       "starting the parent perl for the base server\n", desc);
        -:  182:        }
        -:  183:        else {
       12:  184:            MP_TRACE_i(MP_FUNC,
        -:  185:                       "starting the parent perl for vhost %s\n", desc);
        -:  186:        }
        -:  187:    }
        -:  188:#endif
        -:  189:
        -:  190:#ifdef MP_USE_GTOP
        -:  191:    MP_TRACE_m_do(
        -:  192:        modperl_gtop_do_proc_mem_before(MP_FUNC, "perl_parse");
        -:  193:    );
        -:  194:#endif
        -:  195:
       20:  196:    argv = modperl_config_srv_argv_init(scfg, &argc);
        -:  197:
       20:  198:    if (!(perl = perl_alloc())) {
    #####:  199:        perror("perl_alloc");
    #####:  200:        exit(1);
        -:  201:    }
        -:  202:
        -:  203:#ifdef USE_ITHREADS
       20:  204:    aTHX = perl;
        -:  205:#endif
        -:  206:
       20:  207:    perl_construct(perl);
        -:  208:
       20:  209:    modperl_hash_seed_set(aTHX);
        -:  210:
       20:  211:    modperl_io_apache_init(aTHX);
        -:  212:
       20:  213:    PL_perl_destruct_level = 2;
        -:  214:
       20:  215:    MP_boot_data_set(p, s);
       20:  216:    status = perl_parse(perl, modperl_xs_init, argc, argv, NULL);
       20:  217:    MP_boot_data_set(NULL, NULL);
        -:  218:
       20:  219:    if (status) {
    #####:  220:        perror("perl_parse");
    #####:  221:        exit(1);
        -:  222:    }
        -:  223:
        -:  224:    /* suspend END blocks to be run at server shutdown */
       20:  225:    endav = PL_endav;
       20:  226:    PL_endav = Nullav;
        -:  227:
        -:  228:/* This was fixed in 5.9.0/5.8.1 (17775), but won't compile after 19122 */
        -:  229:#if PERL_REVISION == 5 && PERL_VERSION == 8 && PERL_SUBVERSION == 0 && \
        -:  230:    defined(USE_REENTRANT_API) && defined(HAS_CRYPT_R) && defined(__GLIBC__)
        -:  231:    /* workaround perl5.8.0/glibc bug */
        -:  232:    PL_reentrant_buffer->_crypt_struct.current_saltbits = 0;
        -:  233:#endif
        -:  234:    
       20:  235:    perl_run(perl);
        -:  236:
        -:  237:#ifdef USE_ITHREADS
        -:  238:    /* base server / virtual host w/ +Parent gets its own mip */
       20:  239:    modperl_interp_init(s, p, perl);
        -:  240:
        -:  241:    /* mark the parent perl to be destroyed */
       20:  242:    MpInterpBASE_On(scfg->mip->parent);
        -:  243:#endif
        -:  244:
       20:  245:    PL_endav = endav;
        -:  246:
       20:  247:    set_taint_var(perl);
        -:  248:    
       20:  249:    MP_TRACE_i(MP_FUNC, "constructed interpreter=0x%lx\n",
        -:  250:               (unsigned long)perl);
        -:  251:
        -:  252:#ifdef MP_USE_GTOP
        -:  253:    MP_TRACE_m_do(
        -:  254:        modperl_gtop_do_proc_mem_after(MP_FUNC, "perl_parse");
        -:  255:    );
        -:  256:#endif
        -:  257:
        -:  258:#ifdef MP_COMPAT_1X
       20:  259:    av_push(GvAV(PL_incgv),
        -:  260:            newSVpv(ap_server_root_relative(p, ""), 0));
       20:  261:    av_push(GvAV(PL_incgv),
        -:  262:            newSVpv(ap_server_root_relative(p, "lib/perl"), 0));
        -:  263:#endif /* MP_COMPAT_1X */
        -:  264:    
       20:  265:    if (!modperl_config_apply_PerlRequire(s, scfg, perl, p)) {
    #####:  266:        exit(1);
        -:  267:    }
        -:  268:
       20:  269:    if (!modperl_config_apply_PerlModule(s, scfg, perl, p)) {
    #####:  270:        exit(1);
        -:  271:    }
        -:  272:
        -:  273:#ifndef USE_ITHREADS
        -:  274:    cdata = modperl_cleanup_data_new(server_pool, (void*)perl);
        -:  275:    apr_pool_cleanup_register(server_pool, cdata,
        -:  276:                              modperl_shutdown, apr_pool_cleanup_null);
        -:  277:#endif
        -:  278:
       20:  279:    return perl;
        -:  280:}
        -:  281:
        -:  282:int modperl_init_vhost(server_rec *s, apr_pool_t *p,
        -:  283:                       server_rec *base_server)
      236:  284:{
      236:  285:    MP_dSCFG(s);
      236:  286:    modperl_config_srv_t *base_scfg;
      236:  287:    PerlInterpreter *base_perl;
      236:  288:    PerlInterpreter *perl;
      236:  289:    const char *vhost = modperl_server_desc(s, p);
        -:  290:
      236:  291:    if (!scfg) {
    #####:  292:        MP_TRACE_i(MP_FUNC, "server %s has no mod_perl config\n", vhost);
    #####:  293:        return OK;
        -:  294:    }
        -:  295:
      236:  296:    if (base_server == NULL) {
      168:  297:        base_server = modperl_global_get_server_rec();
        -:  298:    }
        -:  299:
      236:  300:    MP_TRACE_i(MP_FUNC, "Init vhost %s: s=0x%lx, base_s=0x%lx\n",
        -:  301:               vhost, s, base_server);
        -:  302:    
      236:  303:    if (base_server == s) {
       68:  304:        MP_TRACE_i(MP_FUNC, "base server is not vhost, skipping %s\n",
        -:  305:                   vhost);
       68:  306:        return OK;
        -:  307:    }
        -:  308:
      168:  309:    base_scfg = modperl_config_srv_get(base_server);
        -:  310:
        -:  311:#ifdef USE_ITHREADS
      168:  312:    perl = base_perl = base_scfg->mip->parent->perl;
        -:  313:#else
        -:  314:    perl = base_perl = base_scfg->perl;
        -:  315:#endif /* USE_ITHREADS */
        -:  316:
        -:  317:#ifdef USE_ITHREADS
        -:  318:
      168:  319:    if (scfg->mip) {
       84:  320:        MP_TRACE_i(MP_FUNC, "server %s already initialized\n", vhost);
       84:  321:        return OK;
        -:  322:    }
        -:  323:
       84:  324:    if (!MpSrvENABLE(scfg)) {
    #####:  325:        MP_TRACE_i(MP_FUNC, "mod_perl disabled for server %s\n", vhost);
    #####:  326:        scfg->mip = NULL;
    #####:  327:        return OK;
        -:  328:    }
        -:  329:
       84:  330:    PERL_SET_CONTEXT(perl);
        -:  331:
        -:  332:#endif /* USE_ITHREADS */
        -:  333:
       84:  334:    MP_TRACE_d_do(MpSrv_dump_flags(scfg, s->server_hostname));
        -:  335:
        -:  336:    /* if alloc flags is On, virtual host gets its own parent perl */
       84:  337:    if (MpSrvPARENT(scfg)) {
       12:  338:        perl = modperl_startup(s, p);
       12:  339:        MP_TRACE_i(MP_FUNC,
        -:  340:                   "created parent interpreter for VirtualHost %s\n",
        -:  341:                   modperl_server_desc(s, p));
        -:  342:    }
        -:  343:    else {
        -:  344:#ifdef USE_ITHREADS
        -:  345:        /* virtual host w/ +Clone gets its own mip */
       72:  346:        if (MpSrvCLONE(scfg)) {
    #####:  347:            modperl_interp_init(s, p, perl);
        -:  348:        }   
        -:  349:#endif
        -:  350:        
       72:  351:        if (!modperl_config_apply_PerlRequire(s, scfg, perl, p)) {
    #####:  352:            return HTTP_INTERNAL_SERVER_ERROR;
        -:  353:        }
        -:  354:
       72:  355:        if (!modperl_config_apply_PerlModule(s, scfg, perl, p)) {
    #####:  356:            return HTTP_INTERNAL_SERVER_ERROR;
        -:  357:        }
        -:  358:    }
        -:  359:
        -:  360:#ifdef USE_ITHREADS
       84:  361:    if (!scfg->mip) {
        -:  362:        /* since mips are created after merge_server_configs()
        -:  363:         * need to point to the base mip here if this vhost
        -:  364:         * doesn't have its own
        -:  365:         */
       72:  366:        MP_TRACE_i(MP_FUNC, "%s mip inherited from %s\n",
        -:  367:                   vhost, modperl_server_desc(base_server, p));
       72:  368:        scfg->mip = base_scfg->mip;
        -:  369:    }
        -:  370:#endif  /* USE_ITHREADS */
        -:  371:
       84:  372:    return OK;
        -:  373:}
        -:  374:
        -:  375:void modperl_init(server_rec *base_server, apr_pool_t *p)
        8:  376:{
        8:  377:    server_rec *s;
        8:  378:    modperl_config_srv_t *base_scfg;
        8:  379:    PerlInterpreter *base_perl;
        -:  380:
        8:  381:    base_scfg = modperl_config_srv_get(base_server);
        -:  382:
        8:  383:    MP_TRACE_d_do(MpSrv_dump_flags(base_scfg,
        -:  384:                                   base_server->server_hostname));
        -:  385:
        -:  386:#ifndef USE_ITHREADS
        -:  387:    if (base_scfg->threaded_mpm) {
        -:  388:        ap_log_error(APLOG_MARK, APLOG_ERR, 0, base_server,
        -:  389:                     "cannot use threaded MPM without ithreads enabled Perl");
        -:  390:        exit(1);
        -:  391:    }
        -:  392:#endif
        -:  393:
        8:  394:    if (!MpSrvENABLE(base_scfg)) {
        -:  395:        /* how silly */
        8:  396:        return;
        -:  397:    }
        -:  398:
        8:  399:    base_perl = modperl_startup(base_server, p);
        -:  400:
       76:  401:    for (s=base_server->next; s; s=s->next) {
       68:  402:        if (modperl_init_vhost(s, p, base_server) != OK) {
    #####:  403:            exit(1); /*XXX*/
        -:  404:        }
        -:  405:    }
        -:  406:
        -:  407:#ifdef USE_ITHREADS
        -:  408:    /* after other parent perls were started in vhosts, make sure that
        -:  409:     * the context is set to the base_perl */
        8:  410:    PERL_SET_CONTEXT(base_perl);
        -:  411:#endif
        -:  412:
        -:  413:}
        -:  414:
        -:  415:#ifdef USE_ITHREADS
        -:  416:static void modperl_init_clones(server_rec *s, apr_pool_t *p)
        8:  417:{
        8:  418:    modperl_config_srv_t *base_scfg = modperl_config_srv_get(s);
        -:  419:#ifdef MP_TRACE
        8:  420:    char *base_name = modperl_server_desc(s, p);
        -:  421:#endif /* MP_TRACE */
        -:  422:
        8:  423:    if (!base_scfg->threaded_mpm) {
        8:  424:        MP_TRACE_i(MP_FUNC, "no clones created for non-threaded mpm\n");
    #####:  425:        return;
        -:  426:    }
        -:  427:
    #####:  428:    for (; s; s=s->next) {
    #####:  429:        MP_dSCFG(s);
        -:  430:#ifdef MP_TRACE
    #####:  431:        char *name = modperl_server_desc(s, p);
        -:  432:
    #####:  433:        MP_TRACE_i(MP_FUNC, "PerlInterpScope set to %s for %s\n",
        -:  434:                   modperl_interp_scope_desc(scfg->interp_scope), name);
        -:  435:#else
        -:  436:        char *name = NULL;
        -:  437:#endif /* MP_TRACE */
        -:  438:
    #####:  439:        if (scfg->mip->tipool->idle) {
        -:  440:#ifdef MP_TRACE
    #####:  441:            if (scfg->mip == base_scfg->mip) {
    #####:  442:                MP_TRACE_i(MP_FUNC,
        -:  443:                           "%s interp pool inherited from %s\n",
        -:  444:                           name, base_name);
        -:  445:            }
        -:  446:            else {
    #####:  447:                MP_TRACE_i(MP_FUNC,
        -:  448:                           "%s interp pool already initialized\n",
        -:  449:                           name);
        -:  450:            }
        -:  451:#endif /* MP_TRACE */
        -:  452:        }
        -:  453:        else {
    #####:  454:            MP_TRACE_i(MP_FUNC, "initializing interp pool for %s\n",
        -:  455:                       name);
    #####:  456:            modperl_tipool_init(scfg->mip->tipool);
        -:  457:        }
        -:  458:    }
        -:  459:}
        -:  460:#endif /* USE_ITHREADS */
        -:  461:
        -:  462:void modperl_init_globals(server_rec *s, apr_pool_t *pconf)
       10:  463:{
       10:  464:    int threaded_mpm;
       10:  465:    ap_mpm_query(AP_MPMQ_IS_THREADED, &threaded_mpm);
        -:  466:
       10:  467:    MP_TRACE_g(MP_FUNC, "mod_perl globals are configured\n");
        -:  468:    
       10:  469:    modperl_global_init_pconf(pconf, pconf);
       10:  470:    modperl_global_init_threaded_mpm(pconf, threaded_mpm);
       10:  471:    modperl_global_init_server_rec(pconf, s);
        -:  472:
       10:  473:    modperl_tls_create_request_rec(pconf);
        -:  474:}
        -:  475:
        -:  476:/*
        -:  477: * modperl_sys_{init,term} are things that happen
        -:  478: * once per-parent process, not per-interpreter
        -:  479: */
        -:  480:static apr_status_t modperl_sys_init(void)
        8:  481:{
        -:  482:#if 0 /*XXX*/
        -:  483:    PERL_SYS_INIT(0, NULL);
        -:  484:
        -:  485:#ifdef PTHREAD_ATFORK
        -:  486:    if (!ap_exists_config_define("PERL_PTHREAD_ATFORK_DONE")) {
        -:  487:        PTHREAD_ATFORK(Perl_atfork_lock,
        -:  488:                       Perl_atfork_unlock,
        -:  489:                       Perl_atfork_unlock);
        -:  490:        *(char **)apr_array_push(ap_server_config_defines) =
        -:  491:            "PERL_PTHREAD_ATFORK_DONE";
        -:  492:    }
        -:  493:#endif
        -:  494:#endif
        -:  495:
        -:  496:    /* modifies PL_ppaddr */
        8:  497:    modperl_perl_pp_set_all();
        -:  498:
        -:  499:    /* modifies PL_vtbl_env{elem} */
        8:  500:    modperl_env_init();
        -:  501:
        8:  502:    return APR_SUCCESS;
        -:  503:}
        -:  504:
        -:  505:static apr_status_t modperl_sys_term(void *data)
        4:  506:{
        4:  507:    MP_init_status = 0;
        -:  508:
        4:  509:    modperl_env_unload();
        -:  510:
        4:  511:    modperl_perl_pp_unset_all();
        -:  512:
        -:  513:#if 0 /*XXX*/
        -:  514:    PERL_SYS_TERM();
        -:  515:#endif
        4:  516:    return APR_SUCCESS;
        -:  517:}
        -:  518:
        -:  519:int modperl_hook_init(apr_pool_t *pconf, apr_pool_t *plog, 
        -:  520:                      apr_pool_t *ptemp, server_rec *s)
       68:  521:{
       68:  522:    if (MP_IS_STARTING || MP_IS_RUNNING) {
        8:  523:        return OK;
        -:  524:    }
        -:  525:
        8:  526:    MP_init_status = 1; /* now starting */
        -:  527:
        8:  528:    apr_pool_create(&server_pool, pconf);
        -:  529:
        8:  530:    modperl_sys_init();
        8:  531:    apr_pool_cleanup_register(pconf, NULL,
        -:  532:                              modperl_sys_term, apr_pool_cleanup_null);
        -:  533:
        8:  534:    modperl_init(s, pconf);
        -:  535:
       68:  536:    return OK;
        -:  537:}
        -:  538:
        -:  539:/*
        -:  540: * if we need to init earlier than post_config,
        -:  541: * e.g. <Perl> sections or directive handlers.
        -:  542: */
        -:  543:int modperl_run(void)
       60:  544:{
       60:  545:    return modperl_hook_init(modperl_global_get_pconf(),
        -:  546:                             NULL,
        -:  547:                             NULL,
        -:  548:                             modperl_global_get_server_rec());
        -:  549:}
        -:  550:
        -:  551:int modperl_is_running(void)
      736:  552:{
      736:  553:    return MP_IS_RUNNING;
        -:  554:}
        -:  555:
        -:  556:int modperl_hook_pre_config(apr_pool_t *p, apr_pool_t *plog,
        -:  557:                            apr_pool_t *ptemp)
        8:  558:{
        -:  559:    /* we can't have PerlPreConfigHandler without first configuring mod_perl */
        -:  560:
        -:  561:    /* perl 5.8.1+ */
        8:  562:    modperl_hash_seed_init(p);
        -:  563:
        8:  564:    return OK;
        -:  565:}
        -:  566:
        -:  567:static int modperl_hook_pre_connection(conn_rec *c, void *csd)
      407:  568:{
      407:  569:    modperl_input_filter_add_connection(c);
      407:  570:    modperl_output_filter_add_connection(c);
      407:  571:    return OK;
        -:  572:}
        -:  573:
        -:  574:static int modperl_hook_post_config(apr_pool_t *pconf, apr_pool_t *plog,
        -:  575:                                    apr_pool_t *ptemp, server_rec *s)
        8:  576:{
        -:  577:#ifdef USE_ITHREADS
        8:  578:    MP_dSCFG(s);
        8:  579:    dTHXa(scfg->mip->parent->perl);
        -:  580:#endif
        -:  581:
        -:  582:#ifdef MP_TRACE
        -:  583:    /* httpd core open_logs handler re-opens s->error_log, which might
        -:  584:     * change, even though it still points to the same physical file
        -:  585:     * (.e.g on win32 the filehandle will be different. Therefore
        -:  586:     * reset the tracing logfile setting here, since this is the
        -:  587:     * earliest place, happening after the open_logs phase */
        8:  588:    modperl_trace_logfile_set(s->error_log);
        -:  589:#endif
        -:  590:    
        8:  591:    ap_add_version_component(pconf, MP_VERSION_STRING);
        8:  592:    ap_add_version_component(pconf,
        -:  593:                             Perl_form(aTHX_ "Perl/v%vd", PL_patchlevel));
        8:  594:    modperl_mgv_hash_handlers(pconf, s);
        8:  595:    modperl_modglobal_hash_keys(aTHX);
        8:  596:    modperl_env_hash_keys(aTHX);
        -:  597:#ifdef USE_ITHREADS
        8:  598:    modperl_init_clones(s, pconf);
        -:  599:#endif
        -:  600:
        -:  601:#ifdef MP_NEED_HASH_SEED_FIXUP
        -:  602:    ap_log_error(APLOG_MARK, APLOG_INFO, 0, s,
        -:  603:                 "mod_perl: using Perl HASH_SEED: %"UVuf, MP_init_hash_seed);
        -:  604:#endif
        -:  605:    
        8:  606:    return OK;
        -:  607:}
        -:  608:
        -:  609:static int modperl_hook_create_request(request_rec *r)
      453:  610:{
      453:  611:    MP_dRCFG;
        -:  612:
      453:  613:    modperl_config_req_init(r, rcfg);
        -:  614:
        -:  615:    /* set the default for cgi header parsing On as early as possible
        -:  616:     * so $r->content_type in any phase after header_parser could turn
        -:  617:     * it off. wb->header_parse will be set to 1 only if this flag
        -:  618:     * wasn't turned off and MpDirPARSE_HEADERS is on
        -:  619:     */
      453:  620:    MpReqPARSE_HEADERS_On(rcfg);
        -:  621:    
      453:  622:    return OK;
        -:  623:}
        -:  624:
        -:  625:static int modperl_hook_post_read_request(request_rec *r)
      420:  626:{
        -:  627:    /* if 'PerlOptions +GlobalRequest' is outside a container */
      420:  628:    modperl_global_request_cfg_set(r);
        -:  629:
      420:  630:    return OK;
        -:  631:}
        -:  632:
        -:  633:static int modperl_hook_header_parser(request_rec *r)
      420:  634:{    
        -:  635:    /* if 'PerlOptions +GlobalRequest' is inside a container */
      420:  636:    modperl_global_request_cfg_set(r);
        -:  637:
      420:  638:    return OK;
        -:  639:}
        -:  640:
        -:  641:static int modperl_destruct_level = 2; /* default is full tear down */
        -:  642:
        -:  643:int modperl_perl_destruct_level(void)
       10:  644:{
       10:  645:    return modperl_destruct_level;
        -:  646:}
        -:  647:
        -:  648:static apr_status_t modperl_child_exit(void *data)
        4:  649:{
        4:  650:    char *level = NULL;
        4:  651:    server_rec *s = (server_rec *)data;
        -:  652:    
        4:  653:    modperl_callback_process(MP_CHILD_EXIT_HANDLER, server_pool, s, MP_HOOK_VOID);
        -:  654:    
        4:  655:    if ((level = getenv("PERL_DESTRUCT_LEVEL"))) {
    #####:  656:        modperl_destruct_level = atoi(level);
        -:  657:    }
        -:  658:    else {
        -:  659:        /* default to no teardown in the children */
        4:  660:        modperl_destruct_level = 0;
        -:  661:    }
        -:  662:
        4:  663:    if (modperl_destruct_level) {
    #####:  664:        apr_pool_clear(server_pool);
        -:  665:    }
        -:  666:
        4:  667:    server_pool = NULL;
        -:  668:
        4:  669:    return APR_SUCCESS;
        -:  670:}
        -:  671:
        -:  672:static void modperl_hook_child_init(apr_pool_t *p, server_rec *s)
        4:  673:{
        4:  674:    modperl_perl_init_ids_server(s);
        -:  675:
        4:  676:    apr_pool_cleanup_register(p, (void *)s, modperl_child_exit,
        -:  677:                              apr_pool_cleanup_null);
        -:  678:}
        -:  679:
        -:  680:#define MP_FILTER_HANDLER(f) f, NULL
        -:  681:
        -:  682:void modperl_register_hooks(apr_pool_t *p)
       10:  683:{
        -:  684:    /* for <IfDefine MODPERL2> and Apache->define("MODPERL2") */
       10:  685:    *(char **)apr_array_push(ap_server_config_defines) =
        -:  686:        apr_pstrdup(p, "MODPERL2");
        -:  687:
       10:  688:    ap_hook_pre_config(modperl_hook_pre_config,
        -:  689:                       NULL, NULL, APR_HOOK_MIDDLE);
        -:  690:
       10:  691:    ap_hook_open_logs(modperl_hook_init,
        -:  692:                      NULL, NULL, APR_HOOK_FIRST);
        -:  693:
       10:  694:    ap_hook_post_config(modperl_hook_post_config,
        -:  695:                        NULL, NULL, APR_HOOK_FIRST);
        -:  696:
       10:  697:    ap_hook_handler(modperl_response_handler,
        -:  698:                    NULL, NULL, APR_HOOK_MIDDLE);
        -:  699:
       10:  700:    ap_hook_handler(modperl_response_handler_cgi,
        -:  701:                    NULL, NULL, APR_HOOK_MIDDLE);
        -:  702:
       10:  703:    ap_hook_insert_filter(modperl_output_filter_add_request,
        -:  704:                          NULL, NULL, APR_HOOK_LAST);
        -:  705:
       10:  706:    ap_hook_insert_filter(modperl_input_filter_add_request,
        -:  707:                          NULL, NULL, APR_HOOK_LAST);
        -:  708:
       10:  709:    ap_register_output_filter(MP_FILTER_REQUEST_OUTPUT_NAME,
        -:  710:                              MP_FILTER_HANDLER(modperl_output_filter_handler),
        -:  711:                              AP_FTYPE_RESOURCE);
        -:  712:
       10:  713:    ap_register_input_filter(MP_FILTER_REQUEST_INPUT_NAME,
        -:  714:                             MP_FILTER_HANDLER(modperl_input_filter_handler),
        -:  715:                             AP_FTYPE_RESOURCE);
        -:  716:
       10:  717:    ap_register_output_filter(MP_FILTER_CONNECTION_OUTPUT_NAME,
        -:  718:                              MP_FILTER_HANDLER(modperl_output_filter_handler),
        -:  719:                              AP_FTYPE_CONNECTION);
        -:  720:
       10:  721:    ap_register_input_filter(MP_FILTER_CONNECTION_INPUT_NAME,
        -:  722:                             MP_FILTER_HANDLER(modperl_input_filter_handler),
        -:  723:                             AP_FTYPE_CONNECTION);
        -:  724:
       10:  725:    ap_hook_pre_connection(modperl_hook_pre_connection,
        -:  726:                           NULL, NULL, APR_HOOK_FIRST);
        -:  727:
       10:  728:    ap_hook_create_request(modperl_hook_create_request,
        -:  729:                           NULL, NULL, APR_HOOK_MIDDLE);
        -:  730:
        -:  731:    /* both of these hooks need to run really, really first.
        -:  732:     * otherwise, the global request_rec will be set up _after_ some
        -:  733:     * Perl handlers run.
        -:  734:     */
       10:  735:    ap_hook_post_read_request(modperl_hook_post_read_request,
        -:  736:                              NULL, NULL, MODPERL_HOOK_REALLY_REALLY_FIRST);
        -:  737:
       10:  738:    ap_hook_header_parser(modperl_hook_header_parser,
        -:  739:                          NULL, NULL, MODPERL_HOOK_REALLY_REALLY_FIRST);
        -:  740:
       10:  741:    ap_hook_child_init(modperl_hook_child_init,
        -:  742:                       NULL, NULL, APR_HOOK_FIRST);
        -:  743:
       10:  744:    modperl_register_handler_hooks();
        -:  745:}
        -:  746:
        -:  747:static const command_rec modperl_cmds[] = {  
        -:  748:    MP_CMD_SRV_ITERATE("PerlSwitches", switches, "Perl Switches"),
        -:  749:    MP_CMD_SRV_ITERATE("PerlModule", modules, "PerlModule"),
        -:  750:    MP_CMD_SRV_ITERATE("PerlRequire", requires, "PerlRequire"),
        -:  751:    MP_CMD_DIR_ITERATE("PerlOptions", options, "Perl Options"),
        -:  752:    MP_CMD_DIR_ITERATE("PerlInitHandler", init_handlers, "Subroutine name"),
        -:  753:    MP_CMD_DIR_TAKE2("PerlSetVar", set_var, "PerlSetVar"),
        -:  754:    MP_CMD_DIR_ITERATE2("PerlAddVar", add_var, "PerlAddVar"),
        -:  755:    MP_CMD_DIR_TAKE2("PerlSetEnv", set_env, "PerlSetEnv"),
        -:  756:    MP_CMD_SRV_TAKE1("PerlPassEnv", pass_env, "PerlPassEnv"),
        -:  757:    MP_CMD_SRV_RAW_ARGS_ON_READ("<Perl", perl, "Perl Code"),
        -:  758:    MP_CMD_SRV_RAW_ARGS("Perl", perldo, "Perl Code"),
        -:  759:
        -:  760:    MP_CMD_DIR_TAKE1("PerlSetInputFilter", set_input_filter,
        -:  761:                     "filter[;filter]"),
        -:  762:    MP_CMD_DIR_TAKE1("PerlSetOutputFilter", set_output_filter,
        -:  763:                     "filter[;filter]"),
        -:  764:    
        -:  765:    MP_CMD_DIR_RAW_ARGS_ON_READ("=pod", pod, "Start of POD"),
        -:  766:    MP_CMD_DIR_RAW_ARGS_ON_READ("=back", pod, "End of =over"),
        -:  767:    MP_CMD_DIR_RAW_ARGS_ON_READ("=cut", pod_cut, "End of POD"),
        -:  768:    MP_CMD_DIR_RAW_ARGS_ON_READ("__END__", END, "Stop reading config"),
        -:  769:
        -:  770:    MP_CMD_SRV_RAW_ARGS("PerlLoadModule", load_module, "A Perl module"),
        -:  771:#ifdef MP_TRACE
        -:  772:    MP_CMD_SRV_TAKE1("PerlTrace", trace, "Trace level"),
        -:  773:#endif
        -:  774:#ifdef USE_ITHREADS
        -:  775:    MP_CMD_SRV_TAKE1("PerlInterpStart", interp_start,
        -:  776:                     "Number of Perl interpreters to start"),
        -:  777:    MP_CMD_SRV_TAKE1("PerlInterpMax", interp_max,
        -:  778:                     "Max number of running Perl interpreters"),
        -:  779:    MP_CMD_SRV_TAKE1("PerlInterpMaxSpare", interp_max_spare,
        -:  780:                     "Max number of spare Perl interpreters"),
        -:  781:    MP_CMD_SRV_TAKE1("PerlInterpMinSpare", interp_min_spare,
        -:  782:                     "Min number of spare Perl interpreters"),
        -:  783:    MP_CMD_SRV_TAKE1("PerlInterpMaxRequests", interp_max_requests,
        -:  784:                     "Max number of requests per Perl interpreters"),
        -:  785:    MP_CMD_DIR_TAKE1("PerlInterpScope", interp_scope,
        -:  786:                     "Scope of a Perl interpreter"),
        -:  787:#endif
        -:  788:#ifdef MP_COMPAT_1X
        -:  789:    MP_CMD_DIR_FLAG("PerlSendHeader", send_header,
        -:  790:                    "Tell mod_perl to scan output for HTTP headers"),
        -:  791:    MP_CMD_DIR_FLAG("PerlSetupEnv", setup_env,
        -:  792:                    "Turn setup of %ENV On or Off"),
        -:  793:    MP_CMD_DIR_ITERATE("PerlHandler", response_handlers,
        -:  794:                       "Subroutine name"),
        -:  795:    MP_CMD_SRV_FLAG("PerlTaintCheck", taint_check,
        -:  796:                    "Turn on -T switch"),
        -:  797:    MP_CMD_SRV_FLAG("PerlWarn", warn,
        -:  798:                    "Turn on -w switch"),
        -:  799:#endif
        -:  800:    MP_CMD_ENTRIES,
        -:  801:    { NULL }, 
        -:  802:}; 
        -:  803:
        -:  804:void modperl_response_init(request_rec *r)
      349:  805:{
      349:  806:    MP_dRCFG;
      349:  807:    MP_dDCFG;
      349:  808:    modperl_wbucket_t *wb;
        -:  809:
      349:  810:    if (!rcfg->wbucket) {
      349:  811:        rcfg->wbucket =
        -:  812:            (modperl_wbucket_t *)apr_palloc(r->pool,
        -:  813:                                            sizeof(*rcfg->wbucket));
        -:  814:    }
        -:  815:
      349:  816:    wb = rcfg->wbucket;
        -:  817:
        -:  818:    /* setup buffer for output */
      349:  819:    wb->pool = r->pool;
      349:  820:    wb->filters = &r->output_filters;
      349:  821:    wb->outcnt = 0;
      349:  822:    wb->header_parse = MpDirPARSE_HEADERS(dcfg) && MpReqPARSE_HEADERS(rcfg)
        -:  823:        ? 1 : 0;
      349:  824:    wb->r = r;
        -:  825:}
        -:  826:
        -:  827:apr_status_t modperl_response_finish(request_rec *r)
      349:  828:{
      349:  829:    MP_dRCFG;
        -:  830:
        -:  831:    /* flush output buffer */
      349:  832:    return modperl_wbucket_flush(rcfg->wbucket, FALSE);
        -:  833:}
        -:  834:
        -:  835:static int modperl_response_handler_run(request_rec *r, int finish)
      349:  836:{
      349:  837:    int retval;
        -:  838:
      349:  839:    modperl_response_init(r);
        -:  840:
      349:  841:    retval = modperl_callback_per_dir(MP_RESPONSE_HANDLER, r, MP_HOOK_RUN_FIRST);
        -:  842:
      349:  843:    if ((retval == DECLINED) && r->content_type) {
    #####:  844:        r->handler = r->content_type; /* let http_core or whatever try */
        -:  845:    }
        -:  846:
      349:  847:    if (finish) {
      222:  848:        apr_status_t rc = modperl_response_finish(r);
      222:  849:        if (rc != APR_SUCCESS) {
    #####:  850:            retval = rc;
        -:  851:        }
        -:  852:    }
        -:  853:
      349:  854:    return retval;
        -:  855:}
        -:  856:
        -:  857:int modperl_response_handler(request_rec *r)
      364:  858:{
      364:  859:    MP_dDCFG;
      364:  860:    apr_status_t retval;
        -:  861:
        -:  862:#ifdef USE_ITHREADS
      364:  863:    pTHX;
      364:  864:    modperl_interp_t *interp;
        -:  865:#endif
        -:  866:
      364:  867:    if (!strEQ(r->handler, "modperl")) {
      142:  868:        return DECLINED;
        -:  869:    }
        -:  870:
        -:  871:#ifdef USE_ITHREADS
      222:  872:    interp = modperl_interp_select(r, r->connection, r->server);
      222:  873:    aTHX = interp->perl;
        -:  874:#endif
        -:  875:
        -:  876:    /* default is -SetupEnv, add if PerlOption +SetupEnv */
      222:  877:    if (MpDirSETUP_ENV(dcfg)) {
        4:  878:        modperl_env_request_populate(aTHX_ r);
        -:  879:    }
        -:  880:
      222:  881:    retval = modperl_response_handler_run(r, TRUE);
        -:  882:
        -:  883:#ifdef USE_ITHREADS
      222:  884:    if (MpInterpPUTBACK(interp)) {
        -:  885:        /* PerlInterpScope handler */
    #####:  886:        modperl_interp_unselect(interp);
        -:  887:    }
        -:  888:#endif
        -:  889:
      222:  890:    return retval;
        -:  891:}
        -:  892:
        -:  893:int modperl_response_handler_cgi(request_rec *r)
      143:  894:{
      143:  895:    MP_dDCFG;
      143:  896:    GV *h_stdin, *h_stdout;
      143:  897:    apr_status_t retval, rc;
      143:  898:    MP_dRCFG;
        -:  899:#ifdef USE_ITHREADS
      143:  900:    pTHX;
      143:  901:    modperl_interp_t *interp;
        -:  902:#endif
        -:  903:
      143:  904:    if (!strEQ(r->handler, "perl-script")) {
       16:  905:        return DECLINED;
        -:  906:    }
        -:  907:
        -:  908:#ifdef USE_ITHREADS
      127:  909:    interp = modperl_interp_select(r, r->connection, r->server);
      127:  910:    aTHX = interp->perl;
      127:  911:    if (MpInterpPUTBACK(interp)) {
    #####:  912:        rcfg->interp = interp;
        -:  913:    }
        -:  914:#endif
        -:  915:
      127:  916:    modperl_perl_global_request_save(aTHX_ r);
        -:  917:
        -:  918:    /* default is +SetupEnv, skip if PerlOption -SetupEnv */
      127:  919:    if (MpDirSETUP_ENV(dcfg) || !MpDirSeenSETUP_ENV(dcfg)) {
      116:  920:        modperl_env_request_populate(aTHX_ r);
        -:  921:    }
        -:  922:
        -:  923:    /* default is +GlobalRequest, skip if PerlOption -GlobalRequest */
      127:  924:    if (MpDirGLOBAL_REQUEST(dcfg) || !MpDirSeenGLOBAL_REQUEST(dcfg)) {
      126:  925:        modperl_global_request_set(r);
        -:  926:    }
        -:  927:
        -:  928:    /* need to create a block around the IO setup so the temp vars
        -:  929:     * will be automatically cleaned up when we are done with IO */
      127:  930:    ENTER;SAVETMPS;
      127:  931:    h_stdin  = modperl_io_override_stdin(aTHX_ r);
      127:  932:    h_stdout = modperl_io_override_stdout(aTHX_ r);
        -:  933:
      127:  934:    modperl_env_request_tie(aTHX_ r);
        -:  935:
      127:  936:    retval = modperl_response_handler_run(r, FALSE);
        -:  937:
      127:  938:    modperl_env_request_untie(aTHX_ r);
        -:  939:
      127:  940:    modperl_perl_global_request_restore(aTHX_ r);
        -:  941:
      127:  942:    modperl_io_restore_stdin(aTHX_ h_stdin);
      127:  943:    modperl_io_restore_stdout(aTHX_ h_stdout);
      127:  944:    FREETMPS;LEAVE;
        -:  945:
        -:  946:#ifdef USE_ITHREADS
      127:  947:    if (MpInterpPUTBACK(interp)) {
        -:  948:        /* PerlInterpScope handler */
    #####:  949:        modperl_interp_unselect(interp);
    #####:  950:        rcfg->interp = NULL;
        -:  951:    }
        -:  952:#endif
        -:  953:
        -:  954:    /* flush output buffer after interpreter is putback */
      127:  955:    rc = modperl_response_finish(r);
      127:  956:    if (rc != APR_SUCCESS) {
    #####:  957:        retval = rc;
        -:  958:    }
        -:  959:
      127:  960:    switch (rcfg->status) {
        -:  961:      case HTTP_MOVED_TEMPORARILY:
        -:  962:        /* set by modperl_cgi_header_parse */
        3:  963:        retval = HTTP_MOVED_TEMPORARILY;
        -:  964:        break;
        -:  965:    }
        -:  966:
      127:  967:    return retval;
        -:  968:}
        -:  969:
        -:  970:module AP_MODULE_DECLARE_DATA perl_module = {
        -:  971:    STANDARD20_MODULE_STUFF, 
        -:  972:    modperl_config_dir_create, /* dir config creater */
        -:  973:    modperl_config_dir_merge,  /* dir merger --- default is to override */
        -:  974:    modperl_config_srv_create, /* server config */
        -:  975:    modperl_config_srv_merge,  /* merge server config */
        -:  976:    modperl_cmds,              /* table of config file commands       */
        -:  977:    modperl_register_hooks,    /* register hooks */
        -:  978:};