2_0_13/src/modules/perl/modperl_config.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"

void *modperl_config_dir_create(apr_pool_t *p, char *dir)
{
    modperl_config_dir_t *dcfg = modperl_config_dir_new(p);

    dcfg->location = dir;

    MP_TRACE_d(MP_FUNC, "dir %s", dir);

    return dcfg;
}

#define merge_item(item) \
    mrg->item = add->item ? add->item : base->item

static apr_table_t *modperl_table_overlap(apr_pool_t *p,
                                          apr_table_t *base,
                                          apr_table_t *add)
{
    /* take the base (parent) values, and override with add (child) values,
     * generating a new table.  entries in add but not in base will be
     * added to the new table.  all using core apr table routines.
     *
     * note that this is equivalent to apr_table_overlap except a new
     * table is generated, which is required (otherwise we would clobber
     * the existing parent or child configurations)
     *
     * note that this is *not* equivalent to apr_table_overlap, although
     * I think it should be, because apr_table_overlap seems to clear
     * its first argument when the tables have different pools. I think
     * this is wrong -- rici
     */
    apr_table_t *merge = apr_table_overlay(p, base, add);

    /* compress will squash each key to the last value in the table.  this
     * is acceptable for all tables that expect only a single value per key
     * such as PerlPassEnv and PerlSetEnv.  PerlSetVar/PerlAddVar get their
     * own, non-standard, merge routines in merge_table_config_vars.
     */
    apr_table_compress(merge, APR_OVERLAP_TABLES_SET);

    return merge;
}

#define merge_table_overlap_item(item) \
    mrg->item = modperl_table_overlap(p, base->item, add->item)

static apr_table_t *merge_config_add_vars(apr_pool_t *p,
                                          const apr_table_t *base,
                                          const apr_table_t *unset,
                                          const apr_table_t *add)
{
    apr_table_t *temp = apr_table_copy(p, base);

    const apr_array_header_t *arr;
    apr_table_entry_t *entries;
    int i;

    /* for each key in unset do apr_table_unset(temp, key); */
    arr = apr_table_elts(unset);
    entries  = (apr_table_entry_t *)arr->elts;

    /* hopefully this is faster than using apr_table_do  */
    for (i = 0; i < arr->nelts; i++) {
        if (entries[i].key) {
            apr_table_unset(temp, entries[i].key);
        }
    }

    return apr_table_overlay(p, temp, add);
}

#define merge_handlers(merge_flag, array) \
    if (merge_flag(mrg)) { \
        mrg->array = modperl_handler_array_merge(p, \
                                                 base->array, \
                                                 add->array); \
    } \
    else { \
        merge_item(array); \
    }

void *modperl_config_dir_merge(apr_pool_t *p, void *basev, void *addv)
{
    int i;
    modperl_config_dir_t
        *base = (modperl_config_dir_t *)basev,
        *add  = (modperl_config_dir_t *)addv,
        *mrg  = modperl_config_dir_new(p);

    MP_TRACE_d(MP_FUNC, "basev==0x%lx, addv==0x%lx, mrg==0x%lx",
               (unsigned long)basev, (unsigned long)addv,
               (unsigned long)mrg);

    mrg->flags = modperl_options_merge(p, base->flags, add->flags);

    merge_item(location);

    merge_table_overlap_item(SetEnv);

    /* this is where we merge PerlSetVar and PerlAddVar together */
    mrg->configvars = merge_config_add_vars(p,
                                            base->configvars,
                                            add->setvars, add->configvars);
    merge_table_overlap_item(setvars);

    /* XXX: check if Perl*Handler is disabled */
    for (i=0; i < MP_HANDLER_NUM_PER_DIR; i++) {
        merge_handlers(MpDirMERGE_HANDLERS, handlers_per_dir[i]);
    }

    return mrg;
}

modperl_config_req_t *modperl_config_req_new(request_rec *r)
{
    modperl_config_req_t *rcfg =
        (modperl_config_req_t *)apr_pcalloc(r->pool, sizeof(*rcfg));

    MP_TRACE_d(MP_FUNC, "0x%lx", (unsigned long)rcfg);

    return rcfg;
}

modperl_config_con_t *modperl_config_con_new(conn_rec *c)
{
    modperl_config_con_t *ccfg =
        (modperl_config_con_t *)apr_pcalloc(c->pool, sizeof(*ccfg));

    MP_TRACE_d(MP_FUNC, "0x%lx", (unsigned long)ccfg);

    return ccfg;
}

modperl_config_srv_t *modperl_config_srv_new(apr_pool_t *p, server_rec *s)
{
    modperl_config_srv_t *scfg = (modperl_config_srv_t *)
        apr_pcalloc(p, sizeof(*scfg));

    scfg->flags = modperl_options_new(p, MpSrvType);
    MpSrvENABLE_On(scfg); /* mod_perl enabled by default */
    MpSrvHOOKS_ALL_On(scfg); /* all hooks enabled by default */

    scfg->PerlModule  = apr_array_make(p, 2, sizeof(char *));
    scfg->PerlRequire = apr_array_make(p, 2, sizeof(char *));
    scfg->PerlPostConfigRequire =
        apr_array_make(p, 1, sizeof(modperl_require_file_t *));

    /* 2 arguments + NULL terminator */
    scfg->argv = apr_array_make(p, 3, sizeof(char *));

    scfg->setvars = apr_table_make(p, 2);
    scfg->configvars = apr_table_make(p, 2);

    scfg->PassEnv = apr_table_make(p, 2);
    scfg->SetEnv = apr_table_make(p, 2);

#ifdef MP_USE_GTOP
    scfg->gtop = modperl_gtop_new(p);
#endif

    /* make sure httpd's argv[0] is the first argument so $0 is
     * correctly connected to the real thing */
    modperl_config_srv_argv_push(s->process->argv[0]);

    MP_TRACE_d(MP_FUNC, "new scfg: 0x%lx", (unsigned long)scfg);

    return scfg;
}

modperl_config_dir_t *modperl_config_dir_new(apr_pool_t *p)
{
    modperl_config_dir_t *dcfg = (modperl_config_dir_t *)
        apr_pcalloc(p, sizeof(modperl_config_dir_t));

    dcfg->flags = modperl_options_new(p, MpDirType);

    dcfg->setvars = apr_table_make(p, 2);
    dcfg->configvars = apr_table_make(p, 2);

    dcfg->SetEnv = apr_table_make(p, 2);

    MP_TRACE_d(MP_FUNC, "new dcfg: 0x%lx", (unsigned long)dcfg);

    return dcfg;
}

#ifdef MP_TRACE
static void dump_argv(modperl_config_srv_t *scfg)
{
    int i;
    char **argv = (char **)scfg->argv->elts;
    modperl_trace(NULL, "modperl_config_srv_argv_init =>");
    for (i=0; i<scfg->argv->nelts; i++) {
        modperl_trace(NULL, "   %d = %s", i, argv[i]);
    }
}
#endif

char **modperl_config_srv_argv_init(modperl_config_srv_t *scfg, int *argc)
{
    modperl_config_srv_argv_push("-e;0");

    *argc = scfg->argv->nelts;

    /* perl_parse() expects a NULL terminated argv array */
    modperl_config_srv_argv_push(NULL);

    MP_TRACE_g_do(dump_argv(scfg));

    return (char **)scfg->argv->elts;
}

void *modperl_config_srv_create(apr_pool_t *p, server_rec *s)
{
    modperl_config_srv_t *scfg = modperl_config_srv_new(p, s);

    if (!s->is_virtual) {

        /* give a chance to MOD_PERL_TRACE env var to set
         * PerlTrace. This place is the earliest point in mod_perl
         * configuration parsing, when we have the server object
         */
        modperl_trace_level_set_apache(s, NULL);

        /* Must store the global server record as early as possible,
         * because if mod_perl happens to be started from within a
         * vhost (e.g., PerlLoadModule) the base server record won't
         * be available to vhost and things will blow up
         */
        modperl_init_globals(s, p);
    }

    MP_TRACE_d(MP_FUNC, "p=0x%lx, s=0x%lx, virtual=%d",
               p, s, s->is_virtual);

#ifdef USE_ITHREADS

    scfg->interp_pool_cfg =
        (modperl_tipool_config_t *)
        apr_pcalloc(p, sizeof(*scfg->interp_pool_cfg));

    /* XXX: determine reasonable defaults */
    scfg->interp_pool_cfg->start = 3;
    scfg->interp_pool_cfg->max_spare = 3;
    scfg->interp_pool_cfg->min_spare = 3;
    scfg->interp_pool_cfg->max = 5;
    scfg->interp_pool_cfg->max_requests = 2000;
#endif /* USE_ITHREADS */

    scfg->server = s;

    return scfg;
}

/* XXX: this is not complete */
void *modperl_config_srv_merge(apr_pool_t *p, void *basev, void *addv)
{
    int i;
    modperl_config_srv_t
        *base = (modperl_config_srv_t *)basev,
        *add  = (modperl_config_srv_t *)addv,
        *mrg  = modperl_config_srv_new(p, add->server);

    MP_TRACE_d(MP_FUNC, "basev==0x%lx, addv==0x%lx, mrg==0x%lx",
               (unsigned long)basev, (unsigned long)addv,
               (unsigned long)mrg);

    merge_item(modules);
    merge_item(PerlModule);
    merge_item(PerlRequire);
    merge_item(PerlPostConfigRequire);

    merge_table_overlap_item(SetEnv);
    merge_table_overlap_item(PassEnv);

    /* this is where we merge PerlSetVar and PerlAddVar together */
    mrg->configvars = merge_config_add_vars(p,
                                            base->configvars,
                                            add->setvars, add->configvars);
    merge_table_overlap_item(setvars);

    merge_item(server);

#ifdef USE_ITHREADS
    merge_item(interp_pool_cfg);
#else
    merge_item(perl);
#endif

    if (MpSrvINHERIT_SWITCHES(add)) {
        /* only inherit base PerlSwitches if explicitly told to */
        mrg->argv = base->argv;
    }
    else {
        mrg->argv = add->argv;
    }

    mrg->flags = modperl_options_merge(p, base->flags, add->flags);

    /* XXX: check if Perl*Handler is disabled */
    for (i=0; i < MP_HANDLER_NUM_PER_SRV; i++) {
        merge_handlers(MpSrvMERGE_HANDLERS, handlers_per_srv[i]);
    }
    for (i=0; i < MP_HANDLER_NUM_FILES; i++) {
        merge_handlers(MpSrvMERGE_HANDLERS, handlers_files[i]);
    }
    for (i=0; i < MP_HANDLER_NUM_PROCESS; i++) {
        merge_handlers(MpSrvMERGE_HANDLERS, handlers_process[i]);
    }
    for (i=0; i < MP_HANDLER_NUM_PRE_CONNECTION; i++) {
        merge_handlers(MpSrvMERGE_HANDLERS, handlers_pre_connection[i]);
    }
    for (i=0; i < MP_HANDLER_NUM_CONNECTION; i++) {
        merge_handlers(MpSrvMERGE_HANDLERS, handlers_connection[i]);
    }

    if (modperl_is_running()) {
        if (modperl_init_vhost(mrg->server, p, NULL) != OK) {
            exit(1); /*XXX*/
        }
    }

#ifdef USE_ITHREADS
    merge_item(mip);
#endif

    return mrg;
}

/* any per-request cleanup goes here */

apr_status_t modperl_config_request_cleanup(pTHX_ request_rec *r)
{
    apr_status_t retval;
    MP_dRCFG;

    retval = modperl_callback_per_dir(MP_CLEANUP_HANDLER, r, MP_HOOK_RUN_ALL);

    /* undo changes to %ENV caused by +SetupEnv, perl-script, or
     * $r->subprocess_env, so the values won't persist  */
    if (MpReqSETUP_ENV(rcfg)) {
        modperl_env_request_unpopulate(aTHX_ r);
    }

    return retval;
}

apr_status_t modperl_config_req_cleanup(void *data)
{
    request_rec *r = (request_rec *)data;
    apr_status_t rc;
    MP_dINTERPa(r, NULL, NULL);

    rc = modperl_config_request_cleanup(aTHX_ r);

    MP_INTERP_PUTBACK(interp, aTHX);

    return rc;
}

void *modperl_get_perl_module_config(ap_conf_vector_t *cv)
{
    return ap_get_module_config(cv, &perl_module);
}

void modperl_set_perl_module_config(ap_conf_vector_t *cv, void *cfg)
{
    ap_set_module_config(cv, &perl_module, cfg);
}

int modperl_config_apply_PerlModule(server_rec *s,
                                    modperl_config_srv_t *scfg,
                                    PerlInterpreter *perl, apr_pool_t *p)
{
    char **entries;
    int i;
    dTHXa(perl);

    entries = (char **)scfg->PerlModule->elts;
    for (i = 0; i < scfg->PerlModule->nelts; i++){
        if (modperl_require_module(aTHX_ entries[i], TRUE)){
            MP_TRACE_d(MP_FUNC, "loaded Perl module %s for server %s",
                       entries[i], modperl_server_desc(s,p));
        }
        else {
            ap_log_error(APLOG_MARK, APLOG_ERR, 0, s,
                         "Can't load Perl module %s for server %s, exiting...",
                         entries[i], modperl_server_desc(s,p));
            return FALSE;
        }
    }

    return TRUE;
}

int modperl_config_apply_PerlRequire(server_rec *s,
                                     modperl_config_srv_t *scfg,
                                     PerlInterpreter *perl, apr_pool_t *p)
{
    char **entries;
    int i;
    dTHXa(perl);

    entries = (char **)scfg->PerlRequire->elts;
    for (i = 0; i < scfg->PerlRequire->nelts; i++){
        if (modperl_require_file(aTHX_ entries[i], TRUE)){
            MP_TRACE_d(MP_FUNC, "loaded Perl file: %s for server %s",
                       entries[i], modperl_server_desc(s,p));
        }
        else {
            ap_log_error(APLOG_MARK, APLOG_ERR, 0, s,
                         "Can't load Perl file: %s for server %s, exiting...",
                         entries[i], modperl_server_desc(s,p));
            return FALSE;
        }
    }

    return TRUE;
}

int modperl_config_apply_PerlPostConfigRequire(server_rec *s,
                                               modperl_config_srv_t *scfg,
                                               apr_pool_t *p)
{
    modperl_require_file_t **requires;
    int i;
    MP_PERL_CONTEXT_DECLARE;

    requires = (modperl_require_file_t **)scfg->PerlPostConfigRequire->elts;
    for (i = 0; i < scfg->PerlPostConfigRequire->nelts; i++){
        int retval;

        MP_PERL_CONTEXT_STORE_OVERRIDE(scfg->mip->parent->perl);
        retval = modperl_require_file(aTHX_ requires[i]->file, TRUE);
        modperl_env_sync_srv_env_hash2table(aTHX_ p, scfg);
        modperl_env_sync_dir_env_hash2table(aTHX_ p, requires[i]->dcfg);
        MP_PERL_CONTEXT_RESTORE;

        if (retval) {
            MP_TRACE_d(MP_FUNC, "loaded Perl file: %s for server %s",
                       requires[i]->file, modperl_server_desc(s, p));
        }
        else {
            ap_log_error(APLOG_MARK, APLOG_ERR, 0, s,
                         "Can't load Perl file: %s for server %s, exiting...",
                         requires[i]->file, modperl_server_desc(s, p));

            return FALSE;
        }
    }

    return TRUE;
}

typedef struct {
    AV *av;
    I32 ix;
    PerlInterpreter *perl;
} svav_param_t;

static
#if AP_MODULE_MAGIC_AT_LEAST(20110329,0)
apr_status_t
#else
void *
#endif
svav_getstr(void *buf, size_t bufsiz, void *param)
{
    svav_param_t *svav_param = (svav_param_t *)param;
    dTHXa(svav_param->perl);
    AV *av = svav_param->av;
    SV *sv;
    STRLEN n_a;

    if (svav_param->ix > AvFILL(av)) {
#if AP_MODULE_MAGIC_AT_LEAST(20110329,0)
        return APR_EOF;
#else
        return NULL;
#endif
    }

    sv = AvARRAY(av)[svav_param->ix++];
    SvPV_force(sv, n_a);

    apr_cpystrn(buf, SvPVX(sv), bufsiz);

#if AP_MODULE_MAGIC_AT_LEAST(20110329,0)
    return APR_SUCCESS;
#else
    return buf;
#endif
}

const char *modperl_config_insert(pTHX_ server_rec *s,
                                  apr_pool_t *p,
                                  apr_pool_t *ptmp,
                                  int override,
                                  char *path,
                                  int override_options,
                                  ap_conf_vector_t *conf,
                                  SV *lines)
{
    const char *errmsg;
    cmd_parms parms;
    svav_param_t svav_parms;
    ap_directive_t *conftree = NULL;

    memset(&parms, '\0', sizeof(parms));

    parms.limited = -1;
    parms.server = s;
    parms.override = override;
    parms.path = apr_pstrdup(p, path);
    parms.pool = p;
#ifdef MP_HTTPD_HAS_OVERRIDE_OPTS
    if (override_options == MP_HTTPD_OVERRIDE_OPTS_UNSET) {
        parms.override_opts = MP_HTTPD_OVERRIDE_OPTS_DEFAULT;
    }
    else {
        parms.override_opts = override_options;
    }
#endif

    if (ptmp) {
        parms.temp_pool = ptmp;
    }
    else {
        apr_pool_create(&parms.temp_pool, p);
    }

    if (!(SvROK(lines) && (SvTYPE(SvRV(lines)) == SVt_PVAV))) {
        return "not an array reference";
    }

    svav_parms.av = (AV*)SvRV(lines);
    svav_parms.ix = 0;
#ifdef USE_ITHREADS
    svav_parms.perl = aTHX;
#endif

    parms.config_file = ap_pcfg_open_custom(p, "mod_perl",
                                            &svav_parms, NULL,
                                            svav_getstr, NULL);

    errmsg = ap_build_config(&parms, p, parms.temp_pool, &conftree);

    if (!errmsg) {
        errmsg = ap_walk_config(conftree, &parms, conf);
    }

    ap_cfg_closefile(parms.config_file);

    if (ptmp != parms.temp_pool) {
        apr_pool_destroy(parms.temp_pool);
    }

    return errmsg;
}

const char *modperl_config_insert_parms(pTHX_ cmd_parms *parms,
                                        SV *lines)
{
    return modperl_config_insert(aTHX_
                                 parms->server,
                                 parms->pool,
                                 parms->temp_pool,
                                 parms->override,
                                 parms->path,
#ifdef MP_HTTPD_HAS_OVERRIDE_OPTS
                                 parms->override_opts,
#else
                                 MP_HTTPD_OVERRIDE_OPTS_UNSET,
#endif
                                 parms->context,
                                 lines);
}


const char *modperl_config_insert_server(pTHX_ server_rec *s, SV *lines)
{
    int override = (RSRC_CONF | OR_ALL) & ~(OR_AUTHCFG | OR_LIMIT);
    apr_pool_t *p = s->process->pconf;

    return modperl_config_insert(aTHX_ s, p, NULL, override, NULL,
                                 MP_HTTPD_OVERRIDE_OPTS_UNSET,
                                 s->lookup_defaults, lines);
}

const char *modperl_config_insert_request(pTHX_
                                          request_rec *r,
                                          SV *lines,
                                          int override,
                                          char *path,
                                          int override_options)
{
    const char *errmsg;
    ap_conf_vector_t *dconf = ap_create_per_dir_config(r->pool);

    if (!path) {
        /* pass a non-NULL path if nothing else given and for compatibility */
        path = "/";
    }

    errmsg = modperl_config_insert(aTHX_
                                   r->server, r->pool, r->pool,
                                   override, path, override_options,
                                   dconf, lines);

    if (errmsg) {
        return errmsg;
    }

    r->per_dir_config =
        ap_merge_per_dir_configs(r->pool,
                                 r->per_dir_config,
                                 dconf);

    return NULL;
}


/* if r!=NULL check for dir PerlOptions, otherwise check for server
 * PerlOptions, (s must be always set)
 */
int modperl_config_is_perl_option_enabled(pTHX_ request_rec *r,
                                          server_rec *s, const char *name)
{
    U32 flag;

    /* XXX: should we test whether perl is disabled for this server? */
    /*  if (!MpSrvENABLE(scfg)) { */
    /*      return 0;             */
    /*  }                         */

    if (r) {
        if ((flag = modperl_flags_lookup_dir(name)) != -1) {
            MP_dDCFG;
            return MpDirFLAGS(dcfg) & flag ? 1 : 0;
        }
        else {
            Perl_croak(aTHX_ "PerlOptions %s is not a directory option", name);
        }
    }
    else {
        if ((flag = modperl_flags_lookup_srv(name)) != -1) {
            MP_dSCFG(s);
            return MpSrvFLAGS(scfg) & flag ? 1 : 0;
        }
        else {
            Perl_croak(aTHX_ "PerlOptions %s is not a server option", name);
        }
    }

}

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