mod_perl

 view release on metacpan or  search on metacpan

src/modules/perl/mod_perl.c  view on Meta::CPAN

/* 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

src/modules/perl/mod_perl.c  view on Meta::CPAN

/*
 * 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);

src/modules/perl/mod_perl.c  view on Meta::CPAN

     * 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 */

src/modules/perl/mod_perl.c  view on Meta::CPAN

                       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,