xref: /dports/www/mod_perl2/mod_perl-2.0.11/src/modules/perl/mod_perl.c

/* Licensed to the Apache Software Foundation (ASF) under one or more
 * contributor license agreements.  See the NOTICE file distributed with
 * this work for additional information regarding copyright ownership.
 * The ASF licenses this file to You under the Apache License, Version 2.0
 * (the "License"); you may not use this file except in compliance with
 * the License.  You may obtain a copy of the License at
 *
 *     http://www.apache.org/licenses/LICENSE-2.0
 *
 * Unless required by applicable law or agreed to in writing, software
 * distributed under the License is distributed on an "AS IS" BASIS,
 * WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
 * See the License for the specific language governing permissions and
 * limitations under the License.
 */

#include "mod_perl.h"

/* make sure that mod_perl won't try to start itself, while it's
 * already starting. If the flag's value is 1 * it's still starting,
 * when it's 2 it is running */
static int MP_init_status = 0;

#define MP_IS_NOT_RUNNING (MP_init_status == 0 ? 1 : 0)
#define MP_IS_STARTING    (MP_init_status == 1 ? 1 : 0)
#define MP_IS_RUNNING     (MP_init_status == 2 ? 1 : 0)

/* false while there is only the parent process and may be child
 * processes, but no threads around, useful for allowing things that
 * don't require locking and won't affect other threads. It should
 * become true just before the child_init phase  */
static int MP_threads_started = 0;

int modperl_threads_started(void)
{
    return MP_threads_started;
}

static int MP_threaded_mpm = 0;

int modperl_threaded_mpm(void)
{
    return MP_threaded_mpm;
}

/* sometimes non-threaded mpm also needs to know whether it's still
 * starting up or after post_config) */
static int MP_post_post_config_phase = 0;

int modperl_post_post_config_phase(void)
{
    return MP_post_post_config_phase;
}

#ifndef USE_ITHREADS
static apr_status_t modperl_shutdown(void *data)
{
    modperl_cleanup_data_t *cdata = (modperl_cleanup_data_t *)data;
    PerlInterpreter *perl = (PerlInterpreter *)cdata->data;
    void **handles;

    handles = modperl_xs_dl_handles_get(aTHX);

    MP_TRACE_i(MP_FUNC, "destroying interpreter=0x%lx",
               (unsigned long)perl);

    modperl_perl_destruct(perl);

    modperl_xs_dl_handles_close(handles);

    return APR_SUCCESS;
}
#endif

static const char *MP_xs_loaders[] = {
    "Apache2", "APR", NULL,
};

#define MP_xs_loader_name "%s::XSLoader::BOOTSTRAP"

/* ugly hack to have access to startup pool and server during xs_init */
static struct {
    apr_pool_t *p;
    server_rec *s;
} MP_boot_data = {NULL,NULL};

#define MP_boot_data_set(pool, server) \
    MP_boot_data.p = pool; \
    MP_boot_data.s = server

#define MP_dBOOT_DATA \
    apr_pool_t *p = MP_boot_data.p; \
    server_rec *s = MP_boot_data.s

static void modperl_boot(pTHX_ void *data)
{
    MP_dBOOT_DATA;
    int i;

    modperl_env_clear(aTHX);

    modperl_env_default_populate(aTHX);

    modperl_env_configure_server(aTHX_ p, s);

    modperl_perl_core_global_init(aTHX);

    for (i=0; MP_xs_loaders[i]; i++) {
        char *name = Perl_form(aTHX_ MP_xs_loader_name, MP_xs_loaders[i]);
        newCONSTSUB(PL_defstash, name, newSViv(1));
    }

    /* outside mod_perl this is done by ModPerl::Const.xs */
    newXS("ModPerl::Const::compile", XS_modperl_const_compile, __FILE__);

    /* make sure DynaLoader is loaded before XSLoader
     * - to workaround bug in 5.6.1 that can trigger a segv
     * when using modperl as a dso
     * - also needed when <Perl> sections are loaded from +Parent vhost
     */
    modperl_require_module(aTHX_ "DynaLoader", FALSE);

    IoFLUSH_on(PL_stderrgv); /* unbuffer STDERR */
}

static void modperl_xs_init(pTHX)
{
    xs_init(aTHX); /* see modperl_xsinit.c */

    /* XXX: in 5.7.2+ we can call the body of modperl_boot here
     * but in 5.6.1 the Perl runtime is not properly setup yet
     * so we have to pull this stunt to delay
     */
    SAVEDESTRUCTOR_X(modperl_boot, 0);
}

/*
 * the "server_pool" is a subpool of the parent pool (aka "pconf")
 * this is where we register the cleanups that teardown the interpreter.
 * the parent process will run the cleanups since server_pool is a subpool
 * of pconf.  we manually clear the server_pool to run cleanups in the
 * child processes
 *
 * the "server_user_pool" is a subpool of the "server_pool", this is
 * the pool which is exposed to users, so that they can register
 * cleanup callbacks. This is needed so that the perl cleanups won't
 * be run before user cleanups are executed.
 *
 */
static apr_pool_t *server_pool = NULL;
static apr_pool_t *server_user_pool = NULL;

apr_pool_t *modperl_server_pool(void)
{
    return server_pool;
}

apr_pool_t *modperl_server_user_pool(void)
{
    return server_user_pool;
}

static void set_taint_var(PerlInterpreter *perl)
{
    dTHXa(perl);

/* 5.7.3+ has a built-in special ${^TAINT}, backport it to 5.6.0+ */
#if MP_PERL_VERSION_AT_MOST(5, 7, 2)
    {
        GV *gv = gv_fetchpv("\024AINT", GV_ADDMULTI, SVt_IV);
        sv_setiv(GvSV(gv), PL_tainting);
        SvREADONLY_on(GvSV(gv));
    }
#endif /* perl v < 5.7.3 */

#ifdef MP_COMPAT_1X
    {
        GV *gv = gv_fetchpv("Apache2::__T", GV_ADDMULTI, SVt_PV);
        sv_setiv(GvSV(gv), PL_tainting);
        SvREADONLY_on(GvSV(gv));
    }
#endif /* MP_COMPAT_1X */

}

PerlInterpreter *modperl_startup(server_rec *s, apr_pool_t *p)
{
    AV *endav;
    dTHXa(NULL);
    MP_dSCFG(s);
    PerlInterpreter *perl;
    int status;
    char **argv;
    int argc;
#ifndef USE_ITHREADS
    modperl_cleanup_data_t *cdata;
#endif

    /* ensure that we start the base server's perl, before vhost's
     * one, if modperl_startup was called by vhost before the former
     * was started */
    if (MP_init_status != 2) {
        server_rec *base_server = modperl_global_get_server_rec();
        PerlInterpreter *base_perl;

        MP_init_status = 2; /* calls itself, so set the flag early */
        base_perl = modperl_startup(base_server, p);

        if (base_server == s ) {
            return base_perl;
        }
    }

#ifdef MP_TRACE
    {
        server_rec *base_server = modperl_global_get_server_rec();
        const char *desc = modperl_server_desc(s, p);
        if (base_server == s) {
            MP_init_status = 1; /* temporarily reset MP_init_status */
            MP_TRACE_i(MP_FUNC,
                       "starting the parent perl for the base server", desc);
            MP_init_status = 2;
        }
        else {
            MP_TRACE_i(MP_FUNC,
                       "starting the parent perl for vhost %s", desc);
        }
    }
#endif

#ifdef MP_USE_GTOP
    MP_TRACE_m_do(
        modperl_gtop_do_proc_mem_before(MP_FUNC, "perl_parse");
    );
#endif

    argv = modperl_config_srv_argv_init(scfg, &argc);

    if (!(perl = perl_alloc())) {
        perror("perl_alloc");
        exit(1);
    }

#ifdef USE_ITHREADS
    aTHX = perl;
#endif

    perl_construct(perl);

    modperl_hash_seed_set(aTHX);

    modperl_io_apache_init(aTHX);

    PL_perl_destruct_level = 2;

    MP_boot_data_set(p, s);
    status = perl_parse(perl, modperl_xs_init, argc, argv, NULL);
    MP_boot_data_set(NULL, NULL);

    if (status) {
        perror("perl_parse");
        exit(1);
    }

    modperl_env_init(aTHX);

    /* suspend END blocks to be run at server shutdown */
    endav = PL_endav;
    PL_endav = (AV *)NULL;

/* This was fixed in 5.9.0/5.8.1 (17775), but won't compile after 19122 */
#if MP_PERL_VERSION(5, 8, 0) && \
    defined(USE_REENTRANT_API) && defined(HAS_CRYPT_R) && defined(__GLIBC__)
    /* workaround perl5.8.0/glibc bug */
    PL_reentrant_buffer->_crypt_struct.current_saltbits = 0;
#endif

    /* We need to reset $0 to argv[0] (httpd) since perl_parse() will
     * have set it to '-e'. Being magic-aware ensures that some
     * OS-specific magic will happen (i.e. setproctitle() on *BSDs)
     */
    PL_origalen = strlen(argv[0]) + 1;
    sv_setpv_mg(get_sv("0",0), argv[0]);

    perl_run(perl);

#ifdef USE_ITHREADS
    /* base server / virtual host w/ +Parent gets its own mip */
    modperl_interp_init(s, p, perl);

    /* mark the parent perl to be destroyed */
    MpInterpBASE_On(scfg->mip->parent);
#endif

    PL_endav = endav;

    set_taint_var(perl);

    MP_TRACE_i(MP_FUNC, "constructed interpreter=0x%lx",
               (unsigned long)perl);

#ifdef MP_USE_GTOP
    MP_TRACE_m_do(
        modperl_gtop_do_proc_mem_after(MP_FUNC, "perl_parse");
    );
#endif

#ifdef MP_COMPAT_1X
    {
        char *path, *path1;
        apr_finfo_t finfo;
        /* 1) push @INC, $ServerRoot */
        av_push(GvAV(PL_incgv), newSVpv(ap_server_root, 0));

        /* 2) push @INC, $ServerRoot/lib/perl only if it exists */
        apr_filepath_merge(&path, ap_server_root, "lib",
                           APR_FILEPATH_NATIVE, p);
        apr_filepath_merge(&path1, path, "perl",
                           APR_FILEPATH_NATIVE, p);
        if (APR_SUCCESS == apr_stat(&finfo, path1, APR_FINFO_TYPE, p)) {
            if (finfo.filetype == APR_DIR) {
                av_push(GvAV(PL_incgv), newSVpv(path1, 0));
            }
        }
    }
#endif /* MP_COMPAT_1X */

    /* base perl and each vhost +Parent should have this init'ed */
    modperl_handler_anon_init(aTHX_ p);

    if (!modperl_config_apply_PerlRequire(s, scfg, perl, p)) {
        exit(1);
    }

    if (!modperl_config_apply_PerlModule(s, scfg, perl, p)) {
        exit(1);
    }

#ifndef USE_ITHREADS
    cdata = modperl_cleanup_data_new(server_pool, (void*)perl);
    apr_pool_cleanup_register(server_pool, cdata,
                              modperl_shutdown, apr_pool_cleanup_null);
#endif

    return perl;
}

int modperl_init_vhost(server_rec *s, apr_pool_t *p,
                       server_rec *base_server)
{
    MP_dSCFG(s);
    modperl_config_srv_t *base_scfg;
    PerlInterpreter *base_perl;
    PerlInterpreter *perl;
    const char *vhost = modperl_server_desc(s, p);

    if (!scfg) {
        MP_TRACE_i(MP_FUNC, "server %s has no mod_perl config", vhost);
        return OK;
    }

    if (base_server == NULL) {
        base_server = modperl_global_get_server_rec();
    }

    MP_TRACE_i(MP_FUNC, "Init vhost %s: s=0x%lx, base_s=0x%lx",
               vhost, s, base_server);

    if (base_server == s) {
        MP_TRACE_i(MP_FUNC, "base server is not vhost, skipping %s",
                   vhost);
        return OK;
    }

    base_scfg = modperl_config_srv_get(base_server);

#ifdef USE_ITHREADS
    perl = base_perl = base_scfg->mip->parent->perl;
#else
    perl = base_perl = base_scfg->perl;
#endif /* USE_ITHREADS */

#ifdef USE_ITHREADS

    if (scfg->mip) {
        MP_TRACE_i(MP_FUNC, "server %s already initialized", vhost);
        return OK;
    }

    /* the base server could have mod_perl callbacks disabled, but it
     * still needs perl to drive the vhosts */
    if (!MpSrvENABLE(scfg) && s->is_virtual) {
        MP_TRACE_i(MP_FUNC, "mod_perl disabled for server %s", vhost);
        scfg->mip = NULL;
        return OK;
    }

    PERL_SET_CONTEXT(perl);
    modperl_thx_interp_set(perl, base_scfg->mip->parent);

#endif /* USE_ITHREADS */

    MP_TRACE_d_do(MpSrv_dump_flags(scfg, s->server_hostname));

    /* if alloc flags is On, virtual host gets its own parent perl */
    if (MpSrvPARENT(scfg)) {
        perl = modperl_startup(s, p);
        MP_TRACE_i(MP_FUNC,
                   "created parent interpreter for VirtualHost %s",
                   modperl_server_desc(s, p));
    }
    else {
#ifdef USE_ITHREADS
        /* virtual host w/ +Clone gets its own mip */
        if (MpSrvCLONE(scfg)) {
            modperl_interp_init(s, p, perl);
        }
#endif

        if (!modperl_config_apply_PerlRequire(s, scfg, perl, p)) {
            return HTTP_INTERNAL_SERVER_ERROR;
        }

        if (!modperl_config_apply_PerlModule(s, scfg, perl, p)) {
            return HTTP_INTERNAL_SERVER_ERROR;
        }
    }

#ifdef USE_ITHREADS
    if (!scfg->mip) {
        /* since mips are created after merge_server_configs()
         * need to point to the base mip here if this vhost
         * doesn't have its own
         */
        MP_TRACE_i(MP_FUNC, "%s mip inherited from %s",
                   vhost, modperl_server_desc(base_server, p));
        scfg->mip = base_scfg->mip;
    }
#endif  /* USE_ITHREADS */

    return OK;
}

void modperl_init(server_rec *base_server, apr_pool_t *p)
{
    server_rec *s;
    PerlInterpreter *base_perl;
#if defined(MP_TRACE) || defined(USE_ITHREADS)
    modperl_config_srv_t *base_scfg = modperl_config_srv_get(base_server);
#endif

    MP_TRACE_d_do(MpSrv_dump_flags(base_scfg,
                                   base_server->server_hostname));

#ifndef USE_ITHREADS
    if (modperl_threaded_mpm()) {
        ap_log_error(APLOG_MARK, APLOG_ERR, 0, base_server,
                     "cannot use threaded MPM without ithreads enabled Perl");
        exit(1);
    }
#endif

    base_perl = modperl_startup(base_server, p);

    for (s=base_server->next; s; s=s->next) {
        if (modperl_init_vhost(s, p, base_server) != OK) {
            exit(1); /*XXX*/
        }
    }

#ifdef USE_ITHREADS
    /* after other parent perls were started in vhosts, make sure that
     * the context is set to the base_perl */
    PERL_SET_CONTEXT(base_perl);
    modperl_thx_interp_set(base_perl, base_scfg->mip->parent);
#endif

}

static int modperl_post_config_require(server_rec *s, apr_pool_t *p)
{
    for (; s; s=s->next) {
        MP_dSCFG(s);
        if (!modperl_config_apply_PerlPostConfigRequire(s, scfg, p)) {
            return FALSE;
        }
    }
    return TRUE;
}

#ifdef USE_ITHREADS
static void modperl_init_clones(server_rec *s, apr_pool_t *p)
{
#ifdef MP_TRACE
    modperl_config_srv_t *base_scfg = modperl_config_srv_get(s);
    char *base_name = modperl_server_desc(s, p);
#endif /* MP_TRACE */

    if (!modperl_threaded_mpm()) {
        MP_TRACE_i(MP_FUNC, "no clones created for non-threaded mpm");
        return;
    }

    for (; s; s=s->next) {
        MP_dSCFG(s);
#ifdef MP_TRACE
        char *name = modperl_server_desc(s, p);
#else
        char *name = NULL;
#endif /* MP_TRACE */

        if (scfg->mip->tipool->idle) {
#ifdef MP_TRACE
            if (scfg->mip == base_scfg->mip) {
                MP_TRACE_i(MP_FUNC,
                           "%s interp pool inherited from %s",
                           name, base_name);
            }
            else {
                MP_TRACE_i(MP_FUNC,
                           "%s interp pool already initialized",
                           name);
            }
#endif /* MP_TRACE */
        }
        else {
            MP_TRACE_i(MP_FUNC, "initializing interp pool for %s",
                       name);
            modperl_tipool_init(scfg->mip->tipool);
        }
    }
}
#endif /* USE_ITHREADS */

void modperl_init_globals(server_rec *s, apr_pool_t *pconf)
{
    ap_mpm_query(AP_MPMQ_IS_THREADED, &MP_threaded_mpm);

    MP_TRACE_g(MP_FUNC, "mod_perl globals are configured");

    modperl_global_init_pconf(pconf, pconf);
    modperl_global_init_server_rec(pconf, s);

    modperl_tls_create_request_rec(pconf);

    /* init the counter to 0 */
    modperl_global_anon_cnt_init(pconf);
}

/*
 * modperl_sys_{init,term} are things that happen
 * once per-parent process, not per-interpreter
 */
static apr_status_t modperl_sys_init(void)
{
    int argc = 0;
    char **argv = NULL, **env = NULL;

    MP_TRACE_i(MP_FUNC, "mod_perl sys init");

    /* not every OS uses those vars in PERL_SYS_INIT3 macro */
    argc = argc; argv = argv; env = env;

    PERL_SYS_INIT3(&argc, &argv, &env);

#if 0 /*XXX*/
#ifdef PTHREAD_ATFORK
    if (!ap_exists_config_define("PERL_PTHREAD_ATFORK_DONE")) {
        PTHREAD_ATFORK(Perl_atfork_lock,
                       Perl_atfork_unlock,
                       Perl_atfork_unlock);
        *(char **)apr_array_push(ap_server_config_defines) =
            "PERL_PTHREAD_ATFORK_DONE";
    }
#endif
#endif

    /* modifies PL_ppaddr */
    modperl_perl_pp_set_all();

    return APR_SUCCESS;
}

static apr_status_t modperl_sys_term(void *data)
{
    /* PERL_SYS_TERM() needs 'my_perl' as of 5.9.5 */
#if MP_PERL_VERSION_AT_LEAST(5, 9, 5) && defined(USE_ITHREADS)
    modperl_cleanup_data_t *cdata = (modperl_cleanup_data_t *)data;
    PERL_UNUSED_DECL PerlInterpreter *my_perl = cdata == NULL ? NULL : (PerlInterpreter *)cdata->data;
#endif
    MP_init_status = 0;
    MP_threads_started = 0;
    MP_post_post_config_phase = 0;

    MP_PERL_FREE_THREAD_KEY_WORKAROUND;

    MP_TRACE_i(MP_FUNC, "mod_perl sys term");

    modperl_perl_pp_unset_all();

    PERL_SYS_TERM();

    return APR_SUCCESS;
}

int modperl_hook_init(apr_pool_t *pconf, apr_pool_t *plog,
                      apr_pool_t *ptemp, server_rec *s)
{
    if (MP_IS_STARTING || MP_IS_RUNNING) {
        return OK;
    }

    MP_init_status = 1; /* now starting */

    modperl_restart_count_inc(s);

    apr_pool_create(&server_pool, pconf);
    apr_pool_tag(server_pool, "mod_perl server pool");

    apr_pool_create(&server_user_pool, pconf);
    apr_pool_tag(server_user_pool, "mod_perl server user pool");

    modperl_sys_init();
    apr_pool_cleanup_register(server_pool, NULL,
                              modperl_sys_term, apr_pool_cleanup_null);

    modperl_init(s, pconf);

    return OK;
}

/*
 * if we need to init earlier than post_config,
 * e.g. <Perl> sections or directive handlers.
 */
int modperl_run(void)
{
    return modperl_hook_init(modperl_global_get_pconf(),
                             NULL,
                             NULL,
                             modperl_global_get_server_rec());
}

int modperl_is_running(void)
{
    return MP_IS_RUNNING;
}

int modperl_hook_pre_config(apr_pool_t *p, apr_pool_t *plog,
                            apr_pool_t *ptemp)
{
#if AP_MODULE_MAGIC_AT_LEAST(20110329,0)
    ap_reserve_module_slots_directive("PerlLoadModule");
#endif

    /* we can't have PerlPreConfigHandler without first configuring mod_perl */

    /* perl 5.8.1+ */
    modperl_hash_seed_init(p);

    return OK;
}

static int modperl_hook_pre_connection(conn_rec *c, void *csd)
{
    modperl_input_filter_add_connection(c);
    modperl_output_filter_add_connection(c);
    return OK;
}

static int modperl_hook_post_config_last(apr_pool_t *pconf, apr_pool_t *plog,
                                         apr_pool_t *ptemp, server_rec *s)
{
    /* in the threaded environment, no server_rec/process_rec
     * modifications should be done beyond this point */
#ifdef USE_ITHREADS
    MP_dSCFG(s);
    dTHXa(scfg->mip->parent->perl);
#endif

    if (!modperl_post_config_require(s, pconf)) {
        exit(1);
    }

    if (modperl_threaded_mpm()) {
        MP_threads_started = 1;
    }

    MP_post_post_config_phase = 1;

#ifdef MP_TRACE
    /* httpd core open_logs handler re-opens s->error_log, which might
     * change, even though it still points to the same physical file
     * (.e.g on win32 the filehandle will be different. Therefore
     * reset the tracing logfile setting here, since this is the
     * earliest place, happening after the open_logs phase.
     *
     * Moreover, we need to dup the filehandle so that when the server
     * shuts down, we will be able to log to error_log after Apache
     * has closed it (which happens too early for our likening).
     */
    {
        apr_file_t *dup;
        MP_RUN_CROAK(apr_file_dup(&dup, s->error_log, pconf),
                     "mod_perl core post_config");
        modperl_trace_logfile_set(dup);
    }
#endif

#if MP_PERL_VERSION_AT_LEAST(5, 9, 0)
#define MP_PERL_VERSION_STAMP "Perl/%" SVf
#else
#define MP_PERL_VERSION_STAMP "Perl/v%vd"
#endif

    ap_add_version_component(pconf, MP_VERSION_STRING);
    ap_add_version_component(pconf,
                             Perl_form(aTHX_ MP_PERL_VERSION_STAMP,
                                       PL_patchlevel));

    modperl_mgv_hash_handlers(pconf, s);
    modperl_modglobal_hash_keys(aTHX);
    modperl_env_hash_keys(aTHX);
#ifdef USE_ITHREADS
    modperl_init_clones(s, pconf);
#endif

#ifdef MP_NEED_HASH_SEED_FIXUP
    ap_log_error(APLOG_MARK, APLOG_INFO, 0, s,
                 "mod_perl: using Perl HASH_SEED: %"UVuf, MP_init_hash_seed);
#endif

    return OK;
}

static int modperl_hook_create_request(request_rec *r)
{
    MP_dRCFG;

#ifdef USE_ITHREADS
    /* XXX: this is necessary to make modperl_interp_pool_select() work
     * which is used at runtime only to merge dir-configs by
     * modperl_module_config_merge().
     *
     * Since most requests won't need it it would be good to add some logic
     * (cheaper logic in terms of CPU cycles) to identify those cases and
     * avoid the hash operation.
     */
    MP_TRACE_i(MP_FUNC, "setting userdata MODPERL_R in pool %#lx to %lx",
               (unsigned long)r->pool, (unsigned long)r);
    (void)apr_pool_userdata_set((void *)r, "MODPERL_R", NULL, r->pool);
#endif

    modperl_config_req_init(r, rcfg);
    modperl_config_req_cleanup_register(r, rcfg);

    /* set the default for cgi header parsing On as early as possible
     * so $r->content_type in any phase after header_parser could turn
     * it off. wb->header_parse will be set to 1 only if this flag
     * wasn't turned off and MpDirPARSE_HEADERS is on
     */
    MpReqPARSE_HEADERS_On(rcfg);

    return OK;
}

static int modperl_hook_post_read_request(request_rec *r)
{
#ifdef USE_ITHREADS
    MP_TRACE_i(MP_FUNC, "%s %s:%d%s",
               r->method, r->connection->local_addr->hostname,
               r->connection->local_addr->port, r->unparsed_uri);
#endif

    /* if 'PerlOptions +GlobalRequest' is outside a container */
    modperl_global_request_cfg_set(r);

    return OK;
}

static int modperl_hook_header_parser(request_rec *r)
{
    /* if 'PerlOptions +GlobalRequest' is inside a container */
    modperl_global_request_cfg_set(r);

    return OK;
}

static int modperl_destruct_level = 2; /* default is full tear down */

int modperl_perl_destruct_level(void)
{
    return modperl_destruct_level;
}

#ifdef USE_ITHREADS

static apr_status_t
modperl_perl_call_endav_mip(pTHX_ modperl_interp_pool_t *mip,
                            void *data)
{
    modperl_perl_call_endav(aTHX);
    return APR_SUCCESS;
}

#endif /* USE_ITHREADS */

static apr_status_t modperl_child_exit(void *data)
{
    char *level = NULL;
    server_rec *s = (server_rec *)data;

    modperl_callback_process(MP_CHILD_EXIT_HANDLER, server_pool, s,
                             MP_HOOK_VOID);

    if ((level = getenv("PERL_DESTRUCT_LEVEL"))) {
        modperl_destruct_level = atoi(level);
    }
    else {
        /* default to no teardown in the children */
        modperl_destruct_level = 0;
    }

    if (modperl_destruct_level) {
        apr_pool_clear(server_pool);
    }
    else {
        /* run the END blocks of this child process if
         * modperl_perl_destruct is not called for this process */
#ifdef USE_ITHREADS
        modperl_interp_mip_walk_servers(NULL, s,
                                        modperl_perl_call_endav_mip,
                                        (void*)NULL);
#else
        modperl_perl_call_endav(aTHX);
#endif
    }

    server_pool = NULL;

    return APR_SUCCESS;
}

static void modperl_hook_child_init(apr_pool_t *p, server_rec *s)
{
    modperl_perl_init_ids_server(s);

    apr_pool_cleanup_register(p, (void *)s, modperl_child_exit,
                              apr_pool_cleanup_null);
}

#define MP_FILTER_HANDLER(f) f, NULL

void modperl_register_hooks(apr_pool_t *p)
{

#ifdef USE_ITHREADS
    APR_REGISTER_OPTIONAL_FN(modperl_interp_unselect);
    APR_REGISTER_OPTIONAL_FN(modperl_thx_interp_get);
#endif

    /* for <IfDefine MODPERL2> and Apache2->define("MODPERL2") */
    *(char **)apr_array_push(ap_server_config_defines) =
        apr_pstrdup(ap_server_config_defines->pool, "MODPERL2");

    ap_hook_pre_config(modperl_hook_pre_config,
                       NULL, NULL, APR_HOOK_MIDDLE);

    ap_hook_open_logs(modperl_hook_init,
                      NULL, NULL, APR_HOOK_FIRST);

    ap_hook_post_config(modperl_hook_post_config_last,
                        NULL, NULL, APR_HOOK_REALLY_LAST);

    ap_hook_handler(modperl_response_handler,
                    NULL, NULL, APR_HOOK_MIDDLE);

    ap_hook_handler(modperl_response_handler_cgi,
                    NULL, NULL, APR_HOOK_MIDDLE);

    ap_hook_insert_filter(modperl_output_filter_add_request,
                          NULL, NULL, APR_HOOK_LAST);

    ap_hook_insert_filter(modperl_input_filter_add_request,
                          NULL, NULL, APR_HOOK_LAST);

    ap_register_output_filter(MP_FILTER_REQUEST_OUTPUT_NAME,
                              MP_FILTER_HANDLER(modperl_output_filter_handler),
                              AP_FTYPE_RESOURCE);

    ap_register_input_filter(MP_FILTER_REQUEST_INPUT_NAME,
                             MP_FILTER_HANDLER(modperl_input_filter_handler),
                             AP_FTYPE_RESOURCE);

    ap_register_output_filter(MP_FILTER_CONNECTION_OUTPUT_NAME,
                              MP_FILTER_HANDLER(modperl_output_filter_handler),
                              AP_FTYPE_CONNECTION);

    ap_register_input_filter(MP_FILTER_CONNECTION_INPUT_NAME,
                             MP_FILTER_HANDLER(modperl_input_filter_handler),
                             AP_FTYPE_CONNECTION);

    ap_hook_pre_connection(modperl_hook_pre_connection,
                           NULL, NULL, APR_HOOK_FIRST);

    ap_hook_create_request(modperl_hook_create_request,
                           NULL, NULL, APR_HOOK_MIDDLE);

    /* both of these hooks need to run really, really first.
     * otherwise, the global request_rec will be set up _after_ some
     * Perl handlers run.
     */
    ap_hook_post_read_request(modperl_hook_post_read_request,
                              NULL, NULL, MODPERL_HOOK_REALLY_REALLY_FIRST);

    ap_hook_header_parser(modperl_hook_header_parser,
                          NULL, NULL, MODPERL_HOOK_REALLY_REALLY_FIRST);

    ap_hook_child_init(modperl_hook_child_init,
                       NULL, NULL, MODPERL_HOOK_REALLY_REALLY_FIRST);

    modperl_register_handler_hooks();
}

static const command_rec modperl_cmds[] = {
    MP_CMD_SRV_ITERATE("PerlSwitches", switches, "Perl Switches"),
    MP_CMD_DIR_ITERATE("PerlModule", modules, "PerlModule"),
    MP_CMD_DIR_ITERATE("PerlRequire", requires, "PerlRequire"),
    MP_CMD_SRV_ITERATE("PerlConfigRequire", config_requires, "PerlConfigRequire"),
    MP_CMD_SRV_ITERATE("PerlPostConfigRequire", post_config_requires, "PerlPostConfigRequire"),
#if AP_SERVER_MAJORVERSION_NUMBER>2 || \
    (AP_SERVER_MAJORVERSION_NUMBER == 2 && AP_SERVER_MINORVERSION_NUMBER>=3)
    MP_CMD_SRV_TAKE2("PerlAddAuthzProvider", authz_provider, "PerlAddAuthzProvider"),
    MP_CMD_SRV_TAKE2("PerlAddAuthnProvider", authn_provider, "PerlAddAuthnProvider"),
#endif
    MP_CMD_DIR_ITERATE("PerlOptions", options, "Perl Options"),
    MP_CMD_DIR_ITERATE("PerlInitHandler", init_handlers, "Subroutine name"),
    MP_CMD_DIR_TAKE2("PerlSetVar", set_var, "PerlSetVar"),
    MP_CMD_DIR_ITERATE2("PerlAddVar", add_var, "PerlAddVar"),
    MP_CMD_DIR_TAKE2("PerlSetEnv", set_env, "PerlSetEnv"),
    MP_CMD_SRV_TAKE1("PerlPassEnv", pass_env, "PerlPassEnv"),
    MP_CMD_SRV_RAW_ARGS_ON_READ("<Perl", perl, "Perl Code"),
    MP_CMD_SRV_RAW_ARGS("Perl", perldo, "Perl Code"),

    MP_CMD_DIR_TAKE1("PerlSetInputFilter", set_input_filter,
                     "filter[;filter]"),
    MP_CMD_DIR_TAKE1("PerlSetOutputFilter", set_output_filter,
                     "filter[;filter]"),

    MP_CMD_SRV_RAW_ARGS_ON_READ("=pod", pod, "Start of POD"),
    MP_CMD_SRV_RAW_ARGS_ON_READ("=back", pod, "End of =over"),
    MP_CMD_SRV_RAW_ARGS_ON_READ("=cut", pod_cut, "End of POD"),
    MP_CMD_SRV_RAW_ARGS_ON_READ("__END__", END, "Stop reading config"),

    MP_CMD_SRV_RAW_ARGS("PerlLoadModule", load_module, "A Perl module"),
#ifdef MP_TRACE
    MP_CMD_SRV_TAKE1("PerlTrace", trace, "Trace level"),
#endif
#ifdef USE_ITHREADS
    MP_CMD_SRV_TAKE1("PerlInterpStart", interp_start,
                     "Number of Perl interpreters to start"),
    MP_CMD_SRV_TAKE1("PerlInterpMax", interp_max,
                     "Max number of running Perl interpreters"),
    MP_CMD_SRV_TAKE1("PerlInterpMaxSpare", interp_max_spare,
                     "Max number of spare Perl interpreters"),
    MP_CMD_SRV_TAKE1("PerlInterpMinSpare", interp_min_spare,
                     "Min number of spare Perl interpreters"),
    MP_CMD_SRV_TAKE1("PerlInterpMaxRequests", interp_max_requests,
                     "Max number of requests per Perl interpreters"),
#endif
#ifdef MP_COMPAT_1X
    MP_CMD_DIR_FLAG("PerlSendHeader", send_header,
                    "Tell mod_perl to scan output for HTTP headers"),
    MP_CMD_DIR_FLAG("PerlSetupEnv", setup_env,
                    "Turn setup of %ENV On or Off"),
    MP_CMD_DIR_ITERATE("PerlHandler", response_handlers,
                       "Subroutine name"),
    MP_CMD_SRV_FLAG("PerlTaintCheck", taint_check,
                    "Turn on -T switch"),
    MP_CMD_SRV_FLAG("PerlWarn", warn,
                    "Turn on -w switch"),
#endif
    MP_CMD_ENTRIES,
    { NULL },
};

void modperl_response_init(request_rec *r)
{
    MP_dRCFG;
    MP_dDCFG;
    modperl_wbucket_t *wb;

    if (!rcfg->wbucket) {
        rcfg->wbucket =
            (modperl_wbucket_t *)apr_palloc(r->pool,
                                            sizeof(*rcfg->wbucket));
    }

    wb = rcfg->wbucket;

    /* setup buffer for output */
    wb->pool = r->pool;
    wb->filters = &r->output_filters;
    wb->outcnt = 0;
    wb->header_parse = MpDirPARSE_HEADERS(dcfg) && MpReqPARSE_HEADERS(rcfg)
        ? 1 : 0;
    wb->r = r;
}

apr_status_t modperl_response_finish(request_rec *r)
{
    MP_dRCFG;

    /* flush output buffer */
    return modperl_wbucket_flush(rcfg->wbucket, FALSE);
}

static int modperl_response_handler_run(request_rec *r)
{
    int retval;

    modperl_response_init(r);

    retval = modperl_callback_per_dir(MP_RESPONSE_HANDLER, r, MP_HOOK_RUN_FIRST);

    if ((retval == DECLINED) && r->content_type) {
        r->handler = r->content_type; /* let http_core or whatever try */
    }

    return retval;
}

int modperl_response_handler(request_rec *r)
{
    MP_dDCFG;
    apr_status_t retval, rc;
    MP_dINTERP;

    if (!strEQ(r->handler, "modperl")) {
        return DECLINED;
    }

    MP_INTERPa(r, r->connection, r->server);

    /* default is -SetupEnv, add if PerlOption +SetupEnv */
    if (MpDirSETUP_ENV(dcfg)) {
        modperl_env_request_populate(aTHX_ r);
    }

    retval = modperl_response_handler_run(r);
    rc = modperl_response_finish(r);
    if (rc != APR_SUCCESS) {
        retval = rc;
    }

    MP_INTERP_PUTBACK(interp, aTHX);

    return retval;
}

int modperl_response_handler_cgi(request_rec *r)
{
    MP_dDCFG;
    GV *h_stdin, *h_stdout;
    apr_status_t retval, rc;
    MP_dRCFG;
    MP_dINTERP;

    if (!strEQ(r->handler, "perl-script")) {
        return DECLINED;
    }

    MP_INTERPa(r, r->connection, r->server);

    modperl_perl_global_request_save(aTHX_ r);

    /* default is +SetupEnv, skip if PerlOption -SetupEnv */
    if (MpDirSETUP_ENV(dcfg) || !MpDirSeenSETUP_ENV(dcfg)) {
        modperl_env_request_populate(aTHX_ r);
    }

    /* default is +GlobalRequest, skip if PerlOption -GlobalRequest */
    if (MpDirGLOBAL_REQUEST(dcfg) || !MpDirSeenGLOBAL_REQUEST(dcfg)) {
        modperl_global_request_set(r);
    }

    /* need to create a block around the IO setup so the temp vars
     * will be automatically cleaned up when we are done with IO */
    ENTER;SAVETMPS;
    h_stdin  = modperl_io_override_stdin(aTHX_ r);
    h_stdout = modperl_io_override_stdout(aTHX_ r);

    modperl_env_request_tie(aTHX_ r);

    retval = modperl_response_handler_run(r);

    modperl_env_request_untie(aTHX_ r);

    modperl_perl_global_request_restore(aTHX_ r);

    modperl_io_restore_stdin(aTHX_ h_stdin);
    modperl_io_restore_stdout(aTHX_ h_stdout);
    FREETMPS;LEAVE;

    MP_INTERP_PUTBACK(interp, aTHX);

    /* flush output buffer after interpreter is putback */
    rc = modperl_response_finish(r);
    if (rc != APR_SUCCESS) {
        retval = rc;
    }

    switch (rcfg->status) {
      case HTTP_MOVED_TEMPORARILY:
        /* set by modperl_cgi_header_parse */
        retval = HTTP_MOVED_TEMPORARILY;
        break;
    }

    return retval;
}

/* This ugly hack pulls in any function listed in
 * modperl_exports.c. Otherwise, the over-zealous
 * linker would remove unused api functions
 */
const void *modperl_suck_in_ugly_hack(void);
const void *modperl_suck_in_ugly_hack(void)
{
    extern const void *modperl_ugly_hack;
    return modperl_ugly_hack;
}

module AP_MODULE_DECLARE_DATA perl_module = {
    STANDARD20_MODULE_STUFF,
    modperl_config_dir_create, /* dir config creater */
    modperl_config_dir_merge,  /* dir merger --- default is to override */
    modperl_config_srv_create, /* server config */
    modperl_config_srv_merge,  /* merge server config */
    modperl_cmds,              /* table of config file commands       */
    modperl_register_hooks,    /* register hooks */
};

/*
 * Local Variables:
 * c-basic-offset: 4
 * indent-tabs-mode: nil
 * End:
 */