src/modules/perl/modperl_interp.c

/* Copyright 2000-2005 The Apache Software Foundation
 *
 * Licensed 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"

/*
 * XXX: this is not the most efficent interpreter pool implementation
 * but it will do for proof-of-concept
 */

#ifdef USE_ITHREADS

static const char *MP_interp_scope_desc[] = {
    "undef", "handler", "subrequest", "request", "connection",
};

const char *modperl_interp_scope_desc(modperl_interp_scope_e scope)
{
    return MP_interp_scope_desc[scope];
}

void modperl_interp_clone_init(modperl_interp_t *interp)
{
    dTHXa(interp->perl);

    MpInterpCLONED_On(interp);

    PERL_SET_CONTEXT(aTHX);

    /* XXX: hack for bug fixed in 5.6.1 */
    if (PL_scopestack_ix == 0) {
        ENTER;
    }

    /* clear @DynaLoader::dl_librefs so we only dlclose() those
     * which are opened by the clone
     */
    modperl_xs_dl_handles_clear(aTHX);
}

modperl_interp_t *modperl_interp_new(modperl_interp_pool_t *mip,
                                     PerlInterpreter *perl)
{
    UV clone_flags = CLONEf_KEEP_PTR_TABLE;
    modperl_interp_t *interp = 
        (modperl_interp_t *)malloc(sizeof(*interp));

    memset(interp, '\0', sizeof(*interp));

    interp->mip = mip;
    interp->refcnt = 0; /* for use by APR::Pool->cleanup_register */

    if (perl) {
#ifdef MP_USE_GTOP
        MP_dSCFG(mip->server);
        MP_TRACE_m_do(
            modperl_gtop_do_proc_mem_before(MP_FUNC, "perl_clone");
        );
#endif

#if defined(WIN32) && defined(CLONEf_CLONE_HOST)
        clone_flags |= CLONEf_CLONE_HOST;
#endif

        PERL_SET_CONTEXT(perl);

        interp->perl = perl_clone(perl, clone_flags);

#if PERL_REVISION == 5 && PERL_VERSION == 8 && PERL_SUBVERSION == 0 && \
    defined(USE_REENTRANT_API) && defined(HAS_CRYPT_R) && defined(__GLIBC__)
        {
            dTHXa(interp->perl);
            /* workaround 5.8.0 bug */
            PL_reentrant_buffer->_crypt_struct.current_saltbits = 0;
        }
#endif

        {
            PTR_TBL_t *source = modperl_module_config_table_get(perl, FALSE);
            if (source) {
                PTR_TBL_t *table = modperl_svptr_table_clone(interp->perl,
                                                             perl,
                                                             source);

                modperl_module_config_table_set(interp->perl, table);
            }
        }

        /*
         * we keep the PL_ptr_table past perl_clone so it can be used
         * within modperl_svptr_table_clone.
         */
        if ((clone_flags & CLONEf_KEEP_PTR_TABLE)) {
            dTHXa(interp->perl);
            ptr_table_free(PL_ptr_table);
            PL_ptr_table = NULL;
        }

        modperl_interp_clone_init(interp);

        PERL_SET_CONTEXT(perl);

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

    MP_TRACE_i(MP_FUNC, "0x%lx / perl: 0x%lx / parent perl: 0x%lx\n",
               (unsigned long)interp, (unsigned long)interp->perl,
               (unsigned long)perl);

    return interp;
}

void modperl_interp_destroy(modperl_interp_t *interp)
{
    void **handles;
    dTHXa(interp->perl);

    PERL_SET_CONTEXT(interp->perl);

    MP_TRACE_i(MP_FUNC, "interp == 0x%lx / perl: 0x%lx\n",
               (unsigned long)interp, (unsigned long)interp->perl);

    if (MpInterpIN_USE(interp)) {
        MP_TRACE_i(MP_FUNC, "*error - still in use!*\n");
    }

    handles = modperl_xs_dl_handles_get(aTHX);

    modperl_perl_destruct(interp->perl);

    modperl_xs_dl_handles_close(handles);

    free(interp);
}

apr_status_t modperl_interp_cleanup(void *data)
{
    modperl_interp_destroy((modperl_interp_t *)data);
    return APR_SUCCESS;
}

modperl_interp_t *modperl_interp_get(server_rec *s)
{
    MP_dSCFG(s);
    modperl_interp_t *interp = NULL;
    modperl_interp_pool_t *mip = scfg->mip;
    modperl_list_t *head;

    head = modperl_tipool_pop(mip->tipool);
    interp = (modperl_interp_t *)head->data;

    MP_TRACE_i(MP_FUNC, "head == 0x%lx, parent == 0x%lx\n",
               (unsigned long)head, (unsigned long)mip->parent);

    MP_TRACE_i(MP_FUNC, "selected 0x%lx (perl==0x%lx)\n",
               (unsigned long)interp,
               (unsigned long)interp->perl);

#ifdef MP_TRACE
    interp->tid = MP_TIDF;
    MP_TRACE_i(MP_FUNC, "thread == 0x%lx\n", interp->tid);
#endif

    MpInterpIN_USE_On(interp);

    return interp;
}

apr_status_t modperl_interp_pool_destroy(void *data)
{
    modperl_interp_pool_t *mip = (modperl_interp_pool_t *)data;

    if (mip->tipool) {
        modperl_tipool_destroy(mip->tipool);
        mip->tipool = NULL;
    }

    if (MpInterpBASE(mip->parent)) {
        /* multiple mips might share the same parent
         * make sure its only destroyed once
         */
        MP_TRACE_i(MP_FUNC, "parent == 0x%lx\n",
                   (unsigned long)mip->parent);

        modperl_interp_destroy(mip->parent);
    }

    return APR_SUCCESS;
}

static void *interp_pool_grow(modperl_tipool_t *tipool, void *data)
{
    modperl_interp_pool_t *mip = (modperl_interp_pool_t *)data;
    MP_TRACE_i(MP_FUNC, "adding new interpreter to the pool\n");
    return (void *)modperl_interp_new(mip, mip->parent->perl);
}

static void interp_pool_shrink(modperl_tipool_t *tipool, void *data,
                               void *item)
{
    modperl_interp_destroy((modperl_interp_t *)item);
}

static void interp_pool_dump(modperl_tipool_t *tipool, void *data,
                             modperl_list_t *listp)
{
    while (listp) {
        modperl_interp_t *interp = (modperl_interp_t *)listp->data;
        MP_TRACE_i(MP_FUNC, "listp==0x%lx, interp==0x%lx, requests=%d\n",
                 (unsigned long)listp, (unsigned long)interp,
                 interp->num_requests);
        listp = listp->next;
    }
}

static modperl_tipool_vtbl_t interp_pool_func = {
    interp_pool_grow,
    interp_pool_grow,
    interp_pool_shrink,
    interp_pool_shrink,
    interp_pool_dump,
};

void modperl_interp_init(server_rec *s, apr_pool_t *p,
                         PerlInterpreter *perl)
{
    apr_pool_t *server_pool = modperl_server_pool();
    pTHX;
    MP_dSCFG(s);
    modperl_interp_pool_t *mip = 
        (modperl_interp_pool_t *)apr_pcalloc(p, sizeof(*mip));

    MP_TRACE_i(MP_FUNC, "server=%s\n", modperl_server_desc(s, p));

    if (modperl_threaded_mpm()) {
        mip->tipool = modperl_tipool_new(p, scfg->interp_pool_cfg,
                                         &interp_pool_func, mip);
    }

    mip->server = s;
    mip->parent = modperl_interp_new(mip, NULL);
    aTHX = mip->parent->perl = perl;

    /* this happens post-config in mod_perl.c:modperl_init_clones() */
    /* modperl_tipool_init(tipool); */

    apr_pool_cleanup_register(server_pool, (void*)mip,
                              modperl_interp_pool_destroy,
                              apr_pool_cleanup_null);

    scfg->mip = mip;
}

apr_status_t modperl_interp_unselect(void *data)
{
    modperl_interp_t *interp = (modperl_interp_t *)data;
    modperl_interp_pool_t *mip = interp->mip;

    if (interp->refcnt != 0) {
        --interp->refcnt;
        MP_TRACE_i(MP_FUNC, "interp=0x%lx, refcnt=%d\n",
                   (unsigned long)interp, interp->refcnt);
        return APR_SUCCESS;
    }

    if (interp->request) {
        /* ithreads + a threaded mpm + PerlInterpScope handler */
        request_rec *r = interp->request;
        MP_dRCFG;
        modperl_config_request_cleanup(interp->perl, r);
        MpReqCLEANUP_REGISTERED_Off(rcfg);
    }

    MpInterpIN_USE_Off(interp);
    MpInterpPUTBACK_Off(interp);

    MP_THX_INTERP_SET(interp->perl, NULL);

    modperl_tipool_putback_data(mip->tipool, data, interp->num_requests);

    return APR_SUCCESS;
}

/* XXX:
 * interp is marked as in_use for the scope of the pool it is
 * stashed in.  this is done to avoid the tipool->tlock whenever
 * possible.  neither approach is ideal.
 */
#define MP_INTERP_KEY "MODPERL_INTERP"

#define get_interp(p) \
    (void)apr_pool_userdata_get((void **)&interp, MP_INTERP_KEY, p)

#define set_interp(p) \
     (void)apr_pool_userdata_set((void *)interp, MP_INTERP_KEY, \
                                 modperl_interp_unselect, \
                                 p)

modperl_interp_t *modperl_interp_pool_get(apr_pool_t *p)
{
    modperl_interp_t *interp = NULL;
    get_interp(p);
    return interp;
}

void modperl_interp_pool_set(apr_pool_t *p,
                             modperl_interp_t *interp,
                             int cleanup)
{
    /* same as get_interp but optional cleanup  */
    (void)apr_pool_userdata_set((void *)interp, MP_INTERP_KEY,
                                cleanup ? modperl_interp_unselect : NULL,
                                p);
}

/*
 * used in the case where we don't have a request_rec or conn_rec,
 * such as for directive handlers per-{dir,srv} create and merge.
 * "request time pool" is most likely a request_rec->pool.
 */
modperl_interp_t *modperl_interp_pool_select(apr_pool_t *p,
                                             server_rec *s)
{
    int is_startup = (p == s->process->pconf);
    MP_dSCFG(s);
    modperl_interp_t *interp = NULL;

    if (scfg && (is_startup || !modperl_threaded_mpm())) {
        MP_TRACE_i(MP_FUNC, "using parent interpreter at %s\n",
                   is_startup ? "startup" : "request time (non-threaded MPM)");

        if (!scfg->mip) {
            /* we get here if directive handlers are invoked
             * before server merge.
             */
            modperl_init_vhost(s, p, NULL);
        }

        interp = scfg->mip->parent;
    }
    else {
        if (!(interp = modperl_interp_pool_get(p))) {
            interp = modperl_interp_get(s);
            modperl_interp_pool_set(p, interp, TRUE);

            MP_TRACE_i(MP_FUNC, "set interp in request time pool 0x%lx\n",
                       (unsigned long)p);
        }
        else {
            MP_TRACE_i(MP_FUNC, "found interp in request time pool 0x%lx\n",
                       (unsigned long)p);
        }
    }

    return interp;
}

modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c,
                                        server_rec *s)
{
    MP_dSCFG(s);
    MP_dRCFG;
    modperl_config_dir_t *dcfg = modperl_config_dir_get(r);
    const char *desc = NULL;
    modperl_interp_t *interp = NULL;
    apr_pool_t *p = NULL;
    int is_subrequest = (r && r->main) ? 1 : 0;
    modperl_interp_scope_e scope;

    if (!modperl_threaded_mpm()) {
        MP_TRACE_i(MP_FUNC,
                   "using parent 0x%lx for non-threaded mpm (%s:%d)\n",
                   (unsigned long)scfg->mip->parent,
                   s->server_hostname, s->port);
        /* XXX: if no VirtualHosts w/ PerlOptions +Parent we can skip this */
        PERL_SET_CONTEXT(scfg->mip->parent->perl);
        return scfg->mip->parent;
    }

    if (rcfg && rcfg->interp) {
        /* if scope is per-handler and something selected an interpreter
         * before modperl_callback_run_handlers() and is still holding it,
         * e.g. modperl_response_handler_cgi(), that interpreter will
         * be here
         */
        MP_TRACE_i(MP_FUNC,
                   "found interp 0x%lx in request config\n",
                   (unsigned long)rcfg->interp);
        return rcfg->interp;
    }

    /*
     * if a per-dir PerlInterpScope is specified, use it.
     * else if r != NULL use per-server PerlInterpScope
     * else scope must be per-connection
     */

    scope = (dcfg && !modperl_interp_scope_undef(dcfg)) ? 
        dcfg->interp_scope :
        (r ? scfg->interp_scope : MP_INTERP_SCOPE_CONNECTION);

    MP_TRACE_i(MP_FUNC, "scope is per-%s\n",
               modperl_interp_scope_desc(scope));

    /*
     * XXX: goto modperl_interp_get() if scope == handler ?
     */

    if (c && (scope == MP_INTERP_SCOPE_CONNECTION)) {
        desc = "conn_rec pool";
        get_interp(c->pool);

        if (interp) {
            MP_TRACE_i(MP_FUNC,
                       "found interp 0x%lx in %s 0x%lx\n",
                       (unsigned long)interp, desc, (unsigned long)c->pool);
            return interp;
        }

        p = c->pool;
    }
    else if (r) {
        if (is_subrequest && (scope == MP_INTERP_SCOPE_REQUEST)) {
            /* share 1 interpreter across sub-requests */
            request_rec *main_r = r->main;

            while (main_r && !interp) {
                p = main_r->pool;
                get_interp(p);
                MP_TRACE_i(MP_FUNC,
                           "looking for interp in main request for %s...%s\n",
                           main_r->uri, interp ? "found" : "not found");
                main_r = main_r->main;
            }                
        }
        else {
            p = r->pool;
            get_interp(p);
        }

        desc = "request_rec pool";

        if (interp) {
            MP_TRACE_i(MP_FUNC,
                       "found interp 0x%lx in %s 0x%lx (%s request for %s)\n",
                       (unsigned long)interp, desc, (unsigned long)p,
                       (is_subrequest ? "sub" : "main"), r->uri);
            return interp;
        }

        /* might have already been set by a ConnectionHandler */
        get_interp(r->connection->pool);

        if (interp) {
            desc = "r->connection pool";
            MP_TRACE_i(MP_FUNC,
                       "found interp 0x%lx in %s 0x%lx\n",
                       (unsigned long)interp, desc,
                       (unsigned long)r->connection->pool);
            return interp;
        }
    }

    interp = modperl_interp_get(s ? s : r->server);
    ++interp->num_requests; /* should only get here once per request */

    if (scope == MP_INTERP_SCOPE_HANDLER) {
        /* caller is responsible for calling modperl_interp_unselect() */
        interp->request = r;
        MpReqCLEANUP_REGISTERED_On(rcfg);
        MpInterpPUTBACK_On(interp);
    }
    else {
        if (!p) {
            /* should never happen */
            MP_TRACE_i(MP_FUNC, "no pool\n");
            return NULL;
        }

        set_interp(p);

        MP_TRACE_i(MP_FUNC,
                   "set interp 0x%lx in %s 0x%lx (%s request for %s)\n",
                   (unsigned long)interp, desc, (unsigned long)p,
                   (r ? (is_subrequest ? "sub" : "main") : "conn"),
                   (r ? r->uri : c->remote_ip));
    }

    /* set context (THX) for this thread */
    PERL_SET_CONTEXT(interp->perl);

    MP_THX_INTERP_SET(interp->perl, interp);

    return interp;
}

/* currently up to the caller if mip needs locking */
void modperl_interp_mip_walk(PerlInterpreter *current_perl,
                             PerlInterpreter *parent_perl,
                             modperl_interp_pool_t *mip,
                             modperl_interp_mip_walker_t walker,
                             void *data)
{
    modperl_list_t *head = mip->tipool ? mip->tipool->idle : NULL;

    if (!current_perl) {
        current_perl = PERL_GET_CONTEXT;
    }

    if (parent_perl) {
        PERL_SET_CONTEXT(parent_perl);
        walker(parent_perl, mip, data);
    }

    while (head) {
        PerlInterpreter *perl = ((modperl_interp_t *)head->data)->perl;
        PERL_SET_CONTEXT(perl);
        walker(perl, mip, data);
        head = head->next;
    }

    PERL_SET_CONTEXT(current_perl);
}

void modperl_interp_mip_walk_servers(PerlInterpreter *current_perl,
                                     server_rec *base_server,
                                     modperl_interp_mip_walker_t walker,
                                     void *data)
{
    server_rec *s = base_server->next;
    modperl_config_srv_t *base_scfg = modperl_config_srv_get(base_server);
    PerlInterpreter *base_perl = base_scfg->mip->parent->perl;

    modperl_interp_mip_walk(current_perl, base_perl,
                            base_scfg->mip, walker, data);

    while (s) {
        MP_dSCFG(s);
        PerlInterpreter *perl = scfg->mip->parent->perl;
        modperl_interp_pool_t *mip = scfg->mip;

        /* skip vhosts who share parent perl */
        if (perl == base_perl) {
            perl = NULL;
        }

        /* skip vhosts who share parent mip */
        if (scfg->mip == base_scfg->mip) {
            mip = NULL;
        }

        if (perl || mip) {
            modperl_interp_mip_walk(current_perl, perl,
                                    mip, walker, data);
        }

        s = s->next;
    }
}

#else

void modperl_interp_init(server_rec *s, apr_pool_t *p,
                         PerlInterpreter *perl)
{
    MP_dSCFG(s);
    scfg->perl = perl;
}

apr_status_t modperl_interp_cleanup(void *data)
{
    return APR_SUCCESS;
}

#endif /* USE_ITHREADS */