-:    0:Source:modperl_module.c
        -:    0:Object:modperl_module.bb
        -:    1:/* Copyright 2002-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:typedef struct {
        -:   19:    modperl_mgv_t *dir_create;
        -:   20:    modperl_mgv_t *dir_merge;
        -:   21:    modperl_mgv_t *srv_create;
        -:   22:    modperl_mgv_t *srv_merge;
        -:   23:    int namelen;
        -:   24:} modperl_module_info_t;
        -:   25:
        -:   26:typedef struct {
        -:   27:    server_rec *server;
        -:   28:    modperl_module_info_t *minfo;
        -:   29:} modperl_module_cfg_t;
        -:   30:
        -:   31:#define MP_MODULE_INFO(modp) \
        -:   32:    (modperl_module_info_t *)modp->dynamic_load_handle
        -:   33:
        -:   34:#define MP_MODULE_CFG_MINFO(ptr) \
        -:   35:    ((modperl_module_cfg_t *)ptr)->minfo
        -:   36:
        -:   37:static modperl_module_cfg_t *modperl_module_cfg_new(apr_pool_t *p)
      132:   38:{
      132:   39:    modperl_module_cfg_t *cfg =
      264:   40:        (modperl_module_cfg_t *)apr_pcalloc(p, sizeof(*cfg));
        -:   41:
      132:   42:    return cfg;
        -:   43:}
        -:   44:
        -:   45:static modperl_module_cmd_data_t *modperl_module_cmd_data_new(apr_pool_t *p)
       44:   46:{
       44:   47:    modperl_module_cmd_data_t *cmd_data =
       88:   48:        (modperl_module_cmd_data_t *)apr_pcalloc(p, sizeof(*cmd_data));
        -:   49:
       44:   50:    return cmd_data;
        -:   51:}
        -:   52:
        -:   53:static void *modperl_module_config_dir_create(apr_pool_t *p, char *dir)
       68:   54:{
       68:   55:    return modperl_module_cfg_new(p);
        -:   56:}
        -:   57:
        -:   58:static void *modperl_module_config_srv_create(apr_pool_t *p, server_rec *s)
       36:   59:{
       36:   60:    return modperl_module_cfg_new(p);
        -:   61:}
        -:   62:
        -:   63:static SV **modperl_module_config_hash_get(pTHX_ int create)
      257:   64:{
      257:   65:    SV **svp;
        -:   66:
        -:   67:    /* XXX: could make this lookup faster */
      257:   68:    svp = hv_fetch(PL_modglobal,
        -:   69:                   "ModPerl::Module::ConfigTable",
        -:   70:                   MP_SSTRLEN("ModPerl::Module::ConfigTable"),
        -:   71:                   create);
        -:   72:
      257:   73:    return svp;
        -:   74:}
        -:   75:
        -:   76:void modperl_module_config_table_set(pTHX_ PTR_TBL_t *table)
    #####:   77:{
    #####:   78:    SV **svp = modperl_module_config_hash_get(aTHX_ TRUE);
    #####:   79:    sv_setiv(*svp, (IV)table);
        -:   80:}
        -:   81:
        -:   82:PTR_TBL_t *modperl_module_config_table_get(pTHX_ int create)
      257:   83:{
      257:   84:    PTR_TBL_t *table = NULL;
        -:   85:
      257:   86:    SV *sv, **svp = modperl_module_config_hash_get(aTHX_ create);
        -:   87:    
      257:   88:    if (!svp) {
        8:   89:        return NULL;
        -:   90:    }
        -:   91:
      249:   92:    sv = *svp;
      249:   93:    if (!SvIOK(sv) && create) {
        4:   94:        table = modperl_svptr_table_new(aTHX);
        4:   95:        sv_setiv(sv, (IV)table);
        -:   96:    }
        -:   97:    else {
      245:   98:        table = (PTR_TBL_t *)SvIV(sv);
        -:   99:    }
        -:  100:
      249:  101:    return table;
        -:  102:}
        -:  103:
        -:  104:typedef struct {
        -:  105:    PerlInterpreter *perl;
        -:  106:    PTR_TBL_t *table;
        -:  107:    void *ptr;
        -:  108:} config_obj_cleanup_t;
        -:  109:
        -:  110:/*
        -:  111: * any per-dir CREATE or MERGE that happens at request time
        -:  112: * needs to be removed from the pointer table.
        -:  113: */
        -:  114:static apr_status_t modperl_module_config_obj_cleanup(void *data)
       20:  115:{
       20:  116:    config_obj_cleanup_t *cleanup =
       20:  117:        (config_obj_cleanup_t *)data;
       20:  118:    dTHXa(cleanup->perl);
        -:  119:
       20:  120:    modperl_svptr_table_delete(aTHX_ cleanup->table, cleanup->ptr);
        -:  121:
       20:  122:    MP_TRACE_c(MP_FUNC, "deleting ptr 0x%lx from table 0x%lx\n",
        -:  123:               (unsigned long)cleanup->ptr,
        -:  124:               (unsigned long)cleanup->table);
        -:  125:
       20:  126:    return APR_SUCCESS;
        -:  127:}
        -:  128:
        -:  129:static void modperl_module_config_obj_cleanup_register(pTHX_
        -:  130:                                                       apr_pool_t *p,
        -:  131:                                                       PTR_TBL_t *table,
        -:  132:                                                       void *ptr)
       20:  133:{
       20:  134:    config_obj_cleanup_t *cleanup =
       20:  135:        (config_obj_cleanup_t *)apr_palloc(p, sizeof(*cleanup));
        -:  136:
       20:  137:    cleanup->table = table;
       20:  138:    cleanup->ptr = ptr;
        -:  139:#ifdef USE_ITHREADS
       20:  140:    cleanup->perl = aTHX;
        -:  141:#endif
        -:  142:
       20:  143:    apr_pool_cleanup_register(p, cleanup,
        -:  144:                              modperl_module_config_obj_cleanup,
        -:  145:                              apr_pool_cleanup_null);
        -:  146:}
        -:  147:
        -:  148:#define MP_CFG_MERGE_DIR 1
        -:  149:#define MP_CFG_MERGE_SRV 2
        -:  150:
        -:  151:/*
        -:  152: * XXX: vhosts may have different parent interpreters.
        -:  153: */
        -:  154:static void *modperl_module_config_merge(apr_pool_t *p,
        -:  155:                                         void *basev, void *addv,
        -:  156:                                         int type)
       48:  157:{
       48:  158:    GV *gv;
       48:  159:    modperl_mgv_t *method;
       48:  160:    modperl_module_cfg_t *mrg = NULL,
       48:  161:        *tmp,
       48:  162:        *base = (modperl_module_cfg_t *)basev,
       48:  163:        *add  = (modperl_module_cfg_t *)addv;
       48:  164:    server_rec *s;
       48:  165:    int is_startup;
       48:  166:    PTR_TBL_t *table;
       48:  167:    SV *mrg_obj = Nullsv, *base_obj, *add_obj;
        -:  168:
        -:  169:#ifdef USE_ITHREADS
       48:  170:    modperl_interp_t *interp;
       48:  171:    dTHX;
        -:  172:#endif
        -:  173:    
        -:  174:    /* if the module is loaded in vhost, base==NULL */
       48:  175:    tmp = (base && base->server) ? base : add;
        -:  176:
       48:  177:    if (tmp && !tmp->server) {
        -:  178:        /* no directives for this module were encountered so far */
    #####:  179:        return basev;
        -:  180:    }
        -:  181:    
       48:  182:    s = tmp->server;
       48:  183:    is_startup = (p == s->process->pconf);
        -:  184:
        -:  185:#ifdef USE_ITHREADS
       48:  186:    interp = modperl_interp_pool_select(p, s);
       48:  187:    aTHX = interp->perl;
        -:  188:#endif
        -:  189:
       48:  190:    table = modperl_module_config_table_get(aTHX_ TRUE);
       48:  191:    base_obj = modperl_svptr_table_fetch(aTHX_ table, base);
       48:  192:    add_obj  = modperl_svptr_table_fetch(aTHX_ table, add);
        -:  193:
       48:  194:    if (!base_obj || (base_obj == add_obj)) {
       20:  195:        return addv;
        -:  196:    }
        -:  197:
       28:  198:    mrg = modperl_module_cfg_new(p);
       28:  199:    memcpy(mrg, tmp, sizeof(*mrg));
        -:  200:
       28:  201:    method = (type == MP_CFG_MERGE_DIR) ?
        -:  202:        mrg->minfo->dir_merge :
        -:  203:        mrg->minfo->srv_merge;
        -:  204:
       28:  205:    if (method && (gv = modperl_mgv_lookup(aTHX_ method))) {
       22:  206:        int count;
       22:  207:        dSP;
        -:  208:
       22:  209:        MP_TRACE_c(MP_FUNC, "calling %s->%s\n",
        -:  210:                   SvCLASS(base_obj), modperl_mgv_last_name(method));
        -:  211:
       22:  212:        ENTER;SAVETMPS;
       22:  213:        PUSHMARK(sp);
       22:  214:        XPUSHs(base_obj);XPUSHs(add_obj);
        -:  215:
       22:  216:        PUTBACK;
       22:  217:        count = call_sv((SV*)GvCV(gv), G_EVAL|G_SCALAR);
       22:  218:        SPAGAIN;
        -:  219:
       22:  220:        if (count == 1) {
       22:  221:            mrg_obj = SvREFCNT_inc(POPs);
        -:  222:        }
        -:  223:
       22:  224:        PUTBACK;
       22:  225:        FREETMPS;LEAVE;
        -:  226:
       22:  227:        if (SvTRUE(ERRSV)) {
        -:  228:            /* XXX: should die here. */
    #####:  229:            (void)modperl_errsv(aTHX_ HTTP_INTERNAL_SERVER_ERROR,
        -:  230:                                NULL, NULL);
        -:  231:        }
        -:  232:    }
        -:  233:    else {
        6:  234:        mrg_obj = SvREFCNT_inc(add_obj);
        -:  235:    }
        -:  236:
       28:  237:    modperl_svptr_table_store(aTHX_ table, mrg, mrg_obj);
        -:  238:
       28:  239:    if (!is_startup) {
       20:  240:        modperl_module_config_obj_cleanup_register(aTHX_ p, table, mrg);
        -:  241:    }
        -:  242:
       28:  243:    return (void *)mrg;
        -:  244:}
        -:  245:
        -:  246:static void *modperl_module_config_dir_merge(apr_pool_t *p,
        -:  247:                                             void *basev, void *addv)
       32:  248:{
       32:  249:    return modperl_module_config_merge(p, basev, addv,
        -:  250:                                       MP_CFG_MERGE_DIR);
        -:  251:}
        -:  252:
        -:  253:static void *modperl_module_config_srv_merge(apr_pool_t *p,
        -:  254:                                             void *basev, void *addv)
       16:  255:{
       16:  256:    return modperl_module_config_merge(p, basev, addv,
        -:  257:                                       MP_CFG_MERGE_SRV);
        -:  258:}
        -:  259:
        -:  260:#define modperl_bless_cmd_parms(parms) \
        -:  261:    sv_2mortal(modperl_ptr2obj(aTHX_ "Apache::CmdParms", (void *)parms))
        -:  262:
        -:  263:static const char *
        -:  264:modperl_module_config_create_obj(pTHX_
        -:  265:                                 apr_pool_t *p,
        -:  266:                                 PTR_TBL_t *table,
        -:  267:                                 modperl_module_cfg_t *cfg,
        -:  268:                                 modperl_module_cmd_data_t *info,
        -:  269:                                 modperl_mgv_t *method,
        -:  270:                                 cmd_parms *parms,
        -:  271:                                 SV **obj)
      248:  272:{
      248:  273:    const char *mname = info->modp->name;
      248:  274:    modperl_module_info_t *minfo = MP_MODULE_INFO(info->modp);
      248:  275:    GV *gv;
      248:  276:    int is_startup = (p == parms->server->process->pconf);
        -:  277:
        -:  278:    /*
        -:  279:     * XXX: if MPM is not threaded, we could modify the
        -:  280:     * modperl_module_cfg_t * directly and avoid the ptr_table
        -:  281:     * altogether.
        -:  282:     */
      248:  283:    if ((*obj = (SV*)modperl_svptr_table_fetch(aTHX_ table, cfg))) {
        -:  284:        /* object already exists */
      160:  285:        return NULL;
        -:  286:    }
        -:  287:
       88:  288:    MP_TRACE_c(MP_FUNC, "%s cfg=0x%lx for %s.%s\n",
        -:  289:               method, (unsigned long)cfg,
        -:  290:               mname, parms->cmd->name);
        -:  291:
        -:  292:    /* used by merge functions to get a Perl interp */
       88:  293:    cfg->server = parms->server;
       88:  294:    cfg->minfo = minfo;
        -:  295:
       88:  296:    if (method && (gv = modperl_mgv_lookup(aTHX_ method))) {
       12:  297:        int count;
       12:  298:        dSP;
        -:  299:
       12:  300:        ENTER;SAVETMPS;
       12:  301:        PUSHMARK(sp);
       12:  302:        XPUSHs(sv_2mortal(newSVpv(mname, minfo->namelen)));
       12:  303:        XPUSHs(modperl_bless_cmd_parms(parms));
        -:  304:
       12:  305:        PUTBACK;
       12:  306:        count = call_sv((SV*)GvCV(gv), G_EVAL|G_SCALAR);
       12:  307:        SPAGAIN;
        -:  308:
       12:  309:        if (count == 1) {
       12:  310:            *obj = SvREFCNT_inc(POPs);
        -:  311:        }
        -:  312:
       12:  313:        PUTBACK;
       12:  314:        FREETMPS;LEAVE;
        -:  315:
       12:  316:        if (SvTRUE(ERRSV)) {
    #####:  317:            return SvPVX(ERRSV);
        -:  318:        }
        -:  319:    }
        -:  320:    else {
       76:  321:        HV *stash = gv_stashpvn(mname, minfo->namelen, FALSE);
        -:  322:        /* return bless {}, $class */
       76:  323:        *obj = newRV_noinc((SV*)newHV());
       76:  324:        *obj = sv_bless(*obj, stash);
        -:  325:    }
        -:  326:
       88:  327:    if (!is_startup) {
    #####:  328:        modperl_module_config_obj_cleanup_register(aTHX_ p, table, cfg);
        -:  329:    }
        -:  330:
       88:  331:    modperl_svptr_table_store(aTHX_ table, cfg, *obj);
        -:  332:
       88:  333:    return NULL;
        -:  334:}
        -:  335:
        -:  336:#define PUSH_STR_ARG(arg) \
        -:  337:    if (arg) XPUSHs(sv_2mortal(newSVpv(arg,0)))
        -:  338:
        -:  339:static const char *modperl_module_cmd_take123(cmd_parms *parms,
        -:  340:                                              void *mconfig,
        -:  341:                                              const char *one,
        -:  342:                                              const char *two,
        -:  343:                                              const char *three)
      124:  344:{
      124:  345:    modperl_module_cfg_t *cfg = (modperl_module_cfg_t *)mconfig;
      124:  346:    const char *retval = NULL, *errmsg;
      124:  347:    const command_rec *cmd = parms->cmd;
      124:  348:    server_rec *s = parms->server;
      124:  349:    apr_pool_t *p = parms->pool;
      124:  350:    modperl_module_cmd_data_t *info =
      124:  351:        (modperl_module_cmd_data_t *)cmd->cmd_data;
      124:  352:    modperl_module_info_t *minfo = MP_MODULE_INFO(info->modp);
      124:  353:    modperl_module_cfg_t *srv_cfg;
      124:  354:    int modules_alias = 0;
        -:  355:
        -:  356:#ifdef USE_ITHREADS
      124:  357:    modperl_interp_t *interp = modperl_interp_pool_select(p, s);
      124:  358:    dTHXa(interp->perl);
        -:  359:#endif
        -:  360:
      124:  361:    int count;
      124:  362:    PTR_TBL_t *table = modperl_module_config_table_get(aTHX_ TRUE);
      124:  363:    SV *obj = Nullsv;
      124:  364:    dSP;
        -:  365:    
      124:  366:    if (s->is_virtual) {
       72:  367:        MP_dSCFG(s);
        -:  368:
        -:  369:        /* if the Perl module is loaded in the base server and a vhost
        -:  370:         * has configuration directives from that module, but no
        -:  371:         * mod_perl.c directives, scfg == NULL when
        -:  372:         * modperl_module_cmd_take123 is run. If the directive
        -:  373:         * callback wants to do something with the mod_perl config
        -:  374:         * object, it'll segfault, since it doesn't exist yet, because
        -:  375:         * this happens before server configs are merged. So we create
        -:  376:         * a temp struct and fill it in with things that might be
        -:  377:         * needed by the Perl callback.
        -:  378:         */
       72:  379:        if (!scfg) {
        8:  380:            scfg = modperl_config_srv_new(p);
        8:  381:            modperl_set_module_config(s->module_config, scfg);
        8:  382:            scfg->server = s;
        -:  383:        }
        -:  384:
        -:  385:        /* if PerlLoadModule Foo is called from the base server, but
        -:  386:         * Foo's directives are used inside a vhost, we need to
        -:  387:         * temporary link to the base server config's 'modules'
        -:  388:         * member. e.g. so Apache::Module->get_config() can be called
        -:  389:         * from a custom directive's callback, before the server/vhost
        -:  390:         * config merge is performed
        -:  391:         */
       72:  392:        if (!scfg->modules) {
       64:  393:            modperl_config_srv_t *base_scfg =
       64:  394:                modperl_config_srv_get(modperl_global_get_server_rec());
       64:  395:            if (base_scfg->modules) {
       64:  396:                scfg->modules = base_scfg->modules;
       64:  397:                modules_alias = 1;
        -:  398:            }
        -:  399:        }
        -:  400:        
        -:  401:    }
        -:  402:    
      124:  403:    errmsg = modperl_module_config_create_obj(aTHX_ p, table, cfg, info,
        -:  404:                                              minfo->dir_create,
        -:  405:                                              parms, &obj);
        -:  406:
      124:  407:    if (errmsg) {
    #####:  408:        return errmsg;
        -:  409:    }
        -:  410:
      124:  411:    if (obj) {
      124:  412:        MP_TRACE_c(MP_FUNC, "found per-dir obj=0x%lx for %s.%s\n",
        -:  413:                   (unsigned long)obj,
        -:  414:                   info->modp->name, cmd->name);
        -:  415:    }
        -:  416:
        -:  417:    /* XXX: could delay creation of srv_obj until
        -:  418:     * Apache::ModuleConfig->get is called.
        -:  419:     */
      124:  420:    srv_cfg = ap_get_module_config(s->module_config, info->modp);
        -:  421:
      124:  422:    if (srv_cfg) {
      124:  423:        SV *srv_obj;
      124:  424:        errmsg = modperl_module_config_create_obj(aTHX_ p, table, srv_cfg, info,
        -:  425:                                               minfo->srv_create,
        -:  426:                                               parms, &srv_obj);
      124:  427:        if (errmsg) {
    #####:  428:            return errmsg;
        -:  429:        }
        -:  430:
      124:  431:        if (srv_obj) {
      124:  432:            MP_TRACE_c(MP_FUNC, "found per-srv obj=0x%lx for %s.%s\n",
        -:  433:                       (unsigned long)srv_obj,
        -:  434:                       info->modp->name, cmd->name);
        -:  435:        }
        -:  436:    }
        -:  437:
      124:  438:    ENTER;SAVETMPS;
      124:  439:    PUSHMARK(SP);
      124:  440:    EXTEND(SP, 2);
        -:  441:
      124:  442:    PUSHs(obj);
      124:  443:    PUSHs(modperl_bless_cmd_parms(parms));
        -:  444:
      124:  445:    if (cmd->args_how != NO_ARGS) {
      124:  446:        PUSH_STR_ARG(one);
      124:  447:        PUSH_STR_ARG(two);
      124:  448:        PUSH_STR_ARG(three);
        -:  449:    }
        -:  450:
      124:  451:    PUTBACK;
      124:  452:    count = call_method(info->func_name, G_EVAL|G_SCALAR);
      124:  453:    SPAGAIN;
        -:  454:
      124:  455:    if (count == 1) {
      124:  456:        SV *sv = POPs;
      124:  457:        if (SvPOK(sv) && strEQ(SvPVX(sv), DECLINE_CMD)) {
    #####:  458:            retval = DECLINE_CMD;
        -:  459:        }
        -:  460:    }
        -:  461:
      124:  462:    PUTBACK;
      124:  463:    FREETMPS;LEAVE;
        -:  464:
      124:  465:    if (SvTRUE(ERRSV)) {
    #####:  466:        retval = SvPVX(ERRSV);
        -:  467:    }
        -:  468:
      124:  469:    if (modules_alias) {
       64:  470:        MP_dSCFG(s);
        -:  471:        /* unalias the temp aliasing */
       64:  472:        scfg->modules = NULL;
        -:  473:    }
        -:  474:
      124:  475:    return retval;
        -:  476:}
        -:  477:
        -:  478:static const char *modperl_module_cmd_take1(cmd_parms *parms,
        -:  479:                                            void *mconfig,
        -:  480:                                            const char *one)
      120:  481:{
      120:  482:    return modperl_module_cmd_take123(parms, mconfig, one, NULL, NULL);
        -:  483:}
        -:  484:
        -:  485:static const char *modperl_module_cmd_take2(cmd_parms *parms,
        -:  486:                                            void *mconfig,
        -:  487:                                            const char *one,
        -:  488:                                            const char *two)
    #####:  489:{
    #####:  490:    return modperl_module_cmd_take123(parms, mconfig, one, two, NULL);
        -:  491:}
        -:  492:
        -:  493:static const char *modperl_module_cmd_flag(cmd_parms *parms,
        -:  494:                                           void *mconfig,
        -:  495:                                           int flag)
    #####:  496:{
    #####:  497:    char buf[2];
        -:  498:
    #####:  499:    apr_snprintf(buf, sizeof(buf), "%d", flag);
        -:  500:
    #####:  501:    return modperl_module_cmd_take123(parms, mconfig, buf, NULL, NULL);
        -:  502:}
        -:  503:
        -:  504:static const char *modperl_module_cmd_no_args(cmd_parms *parms,
        -:  505:                                              void *mconfig)
    #####:  506:{
    #####:  507:    return modperl_module_cmd_take123(parms, mconfig, NULL, NULL, NULL);
        -:  508:}
        -:  509:
        -:  510:#define modperl_module_cmd_raw_args modperl_module_cmd_take1
        -:  511:#define modperl_module_cmd_iterate  modperl_module_cmd_take1
        -:  512:#define modperl_module_cmd_iterate2 modperl_module_cmd_take2
        -:  513:#define modperl_module_cmd_take12   modperl_module_cmd_take2
        -:  514:#define modperl_module_cmd_take23   modperl_module_cmd_take123
        -:  515:#define modperl_module_cmd_take3    modperl_module_cmd_take123
        -:  516:#define modperl_module_cmd_take13   modperl_module_cmd_take123
        -:  517:
        -:  518:#if defined(AP_HAVE_DESIGNATED_INITIALIZER)
        -:  519:#   define modperl_module_cmd_func_set(cmd, name) \
        -:  520:    cmd->func.name = modperl_module_cmd_##name
        -:  521:#else
        -:  522:#   define modperl_module_cmd_func_set(cmd, name) \
        -:  523:    cmd->func = modperl_module_cmd_##name
        -:  524:#endif
        -:  525:
        -:  526:static int modperl_module_cmd_lookup(command_rec *cmd)
       44:  527:{
       44:  528:    switch (cmd->args_how) {
        -:  529:      case TAKE1:
        -:  530:      case ITERATE:
       40:  531:        modperl_module_cmd_func_set(cmd, take1);
       40:  532:        break;
        -:  533:      case TAKE2:
        -:  534:      case ITERATE2:
        -:  535:      case TAKE12:
    #####:  536:        modperl_module_cmd_func_set(cmd, take2);
    #####:  537:        break;
        -:  538:      case TAKE3:
        -:  539:      case TAKE23:
        -:  540:      case TAKE123:
        -:  541:      case TAKE13:
        4:  542:        modperl_module_cmd_func_set(cmd, take3);
        4:  543:        break;
        -:  544:      case RAW_ARGS:
    #####:  545:        modperl_module_cmd_func_set(cmd, raw_args);
    #####:  546:        break;
        -:  547:      case FLAG:
    #####:  548:        modperl_module_cmd_func_set(cmd, flag);
    #####:  549:        break;
        -:  550:      case NO_ARGS:
    #####:  551:        modperl_module_cmd_func_set(cmd, no_args);
    #####:  552:        break;
        -:  553:      default:
    #####:  554:        return FALSE;
        -:  555:    }
        -:  556:
       44:  557:    return TRUE;
        -:  558:}
        -:  559:
        -:  560:static apr_status_t modperl_module_remove(void *data)
       12:  561:{
       12:  562:    module *modp = (module *)data;
        -:  563:
       12:  564:    ap_remove_loaded_module(modp);
        -:  565:
       12:  566:    return APR_SUCCESS;
        -:  567:}
        -:  568:
        -:  569:static AV *modperl_module_cmds_get(pTHX_ module *modp)
       24:  570:{
       24:  571:    char *name = Perl_form(aTHX_ "%s::%s", modp->name,
       24:  572:                           "APACHE_MODULE_COMMANDS");
       24:  573:    return get_av(name, FALSE);
        -:  574:}
        -:  575:
        -:  576:static const char *modperl_module_cmd_fetch(pTHX_ SV *obj,
        -:  577:                                            const char *name, SV **retval)
      264:  578:{
      264:  579:    const char *errmsg = NULL;
        -:  580:
      264:  581:    if (*retval) {
       80:  582:        SvREFCNT_dec(*retval);
       80:  583:        *retval = Nullsv;
        -:  584:    }
        -:  585:
      264:  586:    if (sv_isobject(obj)) {
    #####:  587:        int count;
    #####:  588:        dSP;
    #####:  589:        ENTER;SAVETMPS;
    #####:  590:        PUSHMARK(SP);
    #####:  591:        XPUSHs(obj);
    #####:  592:        PUTBACK;
        -:  593:
    #####:  594:        count = call_method(name, G_EVAL|G_SCALAR);
        -:  595:
    #####:  596:        SPAGAIN;
        -:  597:
    #####:  598:        if (count == 1) {
    #####:  599:            SV *sv = POPs;
    #####:  600:            if (SvTRUE(sv)) {
    #####:  601:                *retval = SvREFCNT_inc(sv);
        -:  602:            }
        -:  603:        }
        -:  604:
    #####:  605:        if (!*retval) {
    #####:  606:            errmsg = Perl_form(aTHX_ "%s->%s did not return a %svalue",
        -:  607:                               SvCLASS(obj), name, count ? "true " : "");
        -:  608:        }
        -:  609:
    #####:  610:        PUTBACK;
    #####:  611:        FREETMPS;LEAVE;
        -:  612:        
    #####:  613:        if (SvTRUE(ERRSV)) {
    #####:  614:            errmsg = SvPVX(ERRSV);
        -:  615:        }
        -:  616:    }
      264:  617:    else if (SvROK(obj) && (SvTYPE(SvRV(obj)) == SVt_PVHV)) {
      264:  618:        HV *hv = (HV*)SvRV(obj);
      264:  619:        SV **svp = hv_fetch(hv, name, strlen(name), 0);
        -:  620:
      264:  621:        if (svp) {
       84:  622:            *retval = SvREFCNT_inc(*svp);
        -:  623:        }
        -:  624:        else {
      180:  625:            errmsg = Perl_form(aTHX_ "HASH key %s does not exist", name);
        -:  626:        }
        -:  627:    }
        -:  628:    else {
    #####:  629:        errmsg = "command entry is not an object or a HASH reference";
        -:  630:    }
        -:  631:
      264:  632:    return errmsg;
        -:  633:}
        -:  634:
        -:  635:static const char *modperl_module_add_cmds(apr_pool_t *p, server_rec *s,
        -:  636:                                           module *modp)
       24:  637:{
       24:  638:    const char *errmsg;
       24:  639:    apr_array_header_t *cmds;
       24:  640:    command_rec *cmd;
       24:  641:    AV *module_cmds;
       24:  642:    I32 i, fill;
        -:  643:#ifdef USE_ITHREADS
       24:  644:    MP_dSCFG(s);
       24:  645:    dTHXa(scfg->mip->parent->perl);
        -:  646:#endif
        -:  647:
       24:  648:    if (!(module_cmds = modperl_module_cmds_get(aTHX_ modp))) {
    #####:  649:        return apr_pstrcat(p, "module ", modp->name,
        -:  650:                           " does not define @APACHE_MODULE_COMMANDS", NULL);
        -:  651:    }
        -:  652:
       24:  653:    fill = AvFILL(module_cmds);
       24:  654:    cmds = apr_array_make(p, fill+1, sizeof(command_rec));
        -:  655:
       68:  656:    for (i=0; i<=fill; i++) {
       44:  657:        SV *val = Nullsv;
       44:  658:        STRLEN len;
       44:  659:        SV *obj = AvARRAY(module_cmds)[i];
       44:  660:        modperl_module_cmd_data_t *info = modperl_module_cmd_data_new(p);
        -:  661:
       44:  662:        info->modp = modp;
        -:  663:
       44:  664:        cmd = apr_array_push(cmds);
        -:  665:
       44:  666:        if ((errmsg = modperl_module_cmd_fetch(aTHX_ obj, "name", &val))) {
    #####:  667:            return errmsg;
        -:  668:        }
        -:  669:
       44:  670:        cmd->name = apr_pstrdup(p, SvPV(val, len));
        -:  671:
       44:  672:        if ((errmsg = modperl_module_cmd_fetch(aTHX_ obj, "args_how", &val))) {
        -:  673:            /* XXX default based on $self->func prototype */
       36:  674:            cmd->args_how = TAKE1; /* default */
        -:  675:        }
        -:  676:        else {
        8:  677:            if (SvIOK(val)) {
        4:  678:                cmd->args_how = SvIV(val);
        -:  679:            }
        -:  680:            else {
        4:  681:                cmd->args_how =
        -:  682:                    SvIV(modperl_constants_lookup_apache(aTHX_ SvPV(val, len)));
        -:  683:            }
        -:  684:        }
        -:  685:
       44:  686:        if (!modperl_module_cmd_lookup(cmd)) {
    #####:  687:            return apr_psprintf(p,
        -:  688:                                "no command function defined for args_how=%d",
        -:  689:                                cmd->args_how);
        -:  690:        }
        -:  691:
       44:  692:        if ((errmsg = modperl_module_cmd_fetch(aTHX_ obj, "func", &val))) {
       36:  693:            info->func_name = cmd->name;  /* default */
        -:  694:        }
        -:  695:        else {
        8:  696:            info->func_name = apr_pstrdup(p, SvPV(val, len));
        -:  697:        }
        -:  698:
       44:  699:        if ((errmsg = modperl_module_cmd_fetch(aTHX_ obj, "req_override", &val))) {
       32:  700:            cmd->req_override = OR_ALL; /* default */
        -:  701:        }
        -:  702:        else {
       12:  703:            if (SvIOK(val)) {
       12:  704:                cmd->req_override = SvIV(val);
        -:  705:            }
        -:  706:            else {
    #####:  707:                cmd->req_override =
        -:  708:                    SvIV(modperl_constants_lookup_apache(aTHX_ SvPV(val, len)));
        -:  709:            }
        -:  710:        }
        -:  711:
       44:  712:        if ((errmsg = modperl_module_cmd_fetch(aTHX_ obj, "errmsg", &val))) {
        -:  713:            /* default */
        -:  714:            /* XXX generate help msg based on args_how */
       36:  715:            cmd->errmsg = apr_pstrcat(p, cmd->name, " command", NULL);
        -:  716:        }
        -:  717:        else {
        8:  718:            cmd->errmsg = apr_pstrdup(p, SvPV(val, len));
        -:  719:        }
        -:  720:
       44:  721:        cmd->cmd_data = info;
        -:  722:
        -:  723:        /* no default if undefined */
       44:  724:        if (!(errmsg = modperl_module_cmd_fetch(aTHX_ obj, "cmd_data", &val))) {
        4:  725:            info->cmd_data = apr_pstrdup(p, SvPV(val, len));
        -:  726:        }
        -:  727:
       44:  728:        if (val) {
        4:  729:            SvREFCNT_dec(val);
        4:  730:            val = Nullsv;
        -:  731:        }
        -:  732:    }
        -:  733:
       24:  734:    cmd = apr_array_push(cmds);
       24:  735:    cmd->name = NULL;
        -:  736:
       24:  737:    modp->cmds = (command_rec *)cmds->elts;
        -:  738:
       24:  739:    return NULL;
        -:  740:}
        -:  741:
        -:  742:static void modperl_module_insert(module *modp)
       24:  743:{
       24:  744:    module *m;
        -:  745:
        -:  746:    /*
        -:  747:     * insert after mod_perl, rather the top of the list.
        -:  748:     * (see ap_add_module; does not insert into ap_top_module list if
        -:  749:     *  m->next != NULL)
        -:  750:     * this way, modperl config merging happens before this module.
        -:  751:     */
        -:  752:
       24:  753:    for (m = ap_top_module; m; m=m->next) {
       24:  754:        if (m == &perl_module) {
       24:  755:            module *next = m->next;
       24:  756:            m->next = modp;
       24:  757:            modp->next = next;
       24:  758:            break;
        -:  759:        }
        -:  760:    }
        -:  761:}
        -:  762:
        -:  763:#define MP_isGV(gv) (gv && isGV(gv))
        -:  764:
        -:  765:static modperl_mgv_t *modperl_module_fetch_method(pTHX_
        -:  766:                                                  apr_pool_t *p,
        -:  767:                                                  module *modp,
        -:  768:                                                  const char *method)
       96:  769:{
       96:  770:    modperl_mgv_t *mgv;
        -:  771:
       96:  772:    HV *stash = gv_stashpv(modp->name, FALSE);
       96:  773:    GV *gv = gv_fetchmethod_autoload(stash, method, FALSE);
        -:  774:
       96:  775:    MP_TRACE_c(MP_FUNC, "looking for method %s in package `%s'...%sfound\n", 
        -:  776:               method, modp->name,
        -:  777:               MP_isGV(gv) ? "" : "not ");
        -:  778:
       96:  779:    if (!MP_isGV(gv)) {
       68:  780:        return NULL;
        -:  781:    }
        -:  782:
       28:  783:    mgv = modperl_mgv_compile(aTHX_ p,
        -:  784:                              apr_pstrcat(p,
        -:  785:                                          modp->name, "::", method, NULL));
        -:  786:
       96:  787:    return mgv;
        -:  788:}
        -:  789:
        -:  790:const char *modperl_module_add(apr_pool_t *p, server_rec *s,
        -:  791:                               const char *name)
       24:  792:{
       24:  793:    MP_dSCFG(s);
        -:  794:#ifdef USE_ITHREADS
       24:  795:    dTHXa(scfg->mip->parent->perl);
        -:  796:#endif
       24:  797:    const char *errmsg;
       24:  798:    module *modp = (module *)apr_pcalloc(p, sizeof(*modp));
       24:  799:    modperl_module_info_t *minfo =
       48:  800:        (modperl_module_info_t *)apr_pcalloc(p, sizeof(*minfo));
        -:  801:
        -:  802:    /* STANDARD20_MODULE_STUFF */
       24:  803:    modp->version       = MODULE_MAGIC_NUMBER_MAJOR;
       24:  804:    modp->minor_version = MODULE_MAGIC_NUMBER_MINOR;
       24:  805:    modp->module_index  = -1;
       24:  806:    modp->name          = apr_pstrdup(p, name);
       24:  807:    modp->magic         = MODULE_MAGIC_COOKIE;
        -:  808:
        -:  809:    /* use this slot for our context */
       24:  810:    modp->dynamic_load_handle = minfo;
        -:  811:
        -:  812:    /* 
        -:  813:     * XXX: we should lookup here if the Perl methods exist,
        -:  814:     * and set these pointers only if they do.
        -:  815:     */
       24:  816:    modp->create_dir_config    = modperl_module_config_dir_create;
       24:  817:    modp->merge_dir_config     = modperl_module_config_dir_merge;
       24:  818:    modp->create_server_config = modperl_module_config_srv_create;
       24:  819:    modp->merge_server_config  = modperl_module_config_srv_merge;
        -:  820:
       24:  821:    minfo->namelen = strlen(name);
        -:  822:
       24:  823:    minfo->dir_create =
        -:  824:        modperl_module_fetch_method(aTHX_ p, modp, "DIR_CREATE");
        -:  825:
       24:  826:    minfo->dir_merge =
        -:  827:        modperl_module_fetch_method(aTHX_ p, modp, "DIR_MERGE");
        -:  828:
       24:  829:    minfo->srv_create =
        -:  830:        modperl_module_fetch_method(aTHX_ p, modp, "SERVER_CREATE");
        -:  831:
       24:  832:    minfo->srv_merge =
        -:  833:        modperl_module_fetch_method(aTHX_ p, modp, "SERVER_MERGE");
        -:  834:
       24:  835:    modp->cmds = NULL;
        -:  836:
       24:  837:    if ((errmsg = modperl_module_add_cmds(p, s, modp))) {
    #####:  838:        return errmsg;
        -:  839:    }
        -:  840:
       24:  841:    modperl_module_insert(modp);
        -:  842:
       24:  843:    ap_add_loaded_module(modp, p);
        -:  844:
       24:  845:    apr_pool_cleanup_register(p, modp, modperl_module_remove,
        -:  846:                              apr_pool_cleanup_null);
        -:  847:
       24:  848:    ap_single_module_configure(p, s, modp);
        -:  849:
       24:  850:    if (!scfg->modules) {
        8:  851:        scfg->modules = apr_hash_make(p);
        -:  852:    }
        -:  853:
       24:  854:    apr_hash_set(scfg->modules, name, APR_HASH_KEY_STRING, modp);
        -:  855:
        -:  856:#ifdef USE_ITHREADS
        -:  857:    /* 
        -:  858:     * if the Perl module is loaded in the base server and a vhost
        -:  859:     * has configuration directives from that module, but no mod_perl.c
        -:  860:     * directives, scfg == NULL when modperl_module_cmd_take123 is run.
        -:  861:     * this happens before server configs are merged, so we stash a pointer
        -:  862:     * to what will be merged as the parent interp later. i.e. "safe hack"
        -:  863:     */
       24:  864:    if (!modperl_interp_pool_get(p)) {
        -:  865:        /* for vhosts */
        4:  866:        modperl_interp_pool_set(p, scfg->mip->parent, FALSE);
        -:  867:    }
        -:  868:#endif
        -:  869:
       24:  870:    return NULL;
        -:  871:}
        -:  872:
        -:  873:SV *modperl_module_config_get_obj(pTHX_ SV *pmodule, server_rec *s, 
        -:  874:                                  ap_conf_vector_t *v)
       75:  875:{
       75:  876:    MP_dSCFG(s);
       75:  877:    module *modp;
       75:  878:    const char *name;
       75:  879:    void *ptr;
       75:  880:    PTR_TBL_t *table;
       75:  881:    SV *obj;
        -:  882:
       75:  883:    if (!v) {
       66:  884:        v = s->module_config;
        -:  885:    }
        -:  886:
       75:  887:    if (SvROK(pmodule)) {
       56:  888:        name = SvCLASS(pmodule);
        -:  889:    }
        -:  890:    else {
       19:  891:        STRLEN n_a;
       19:  892:        name = SvPV(pmodule, n_a);
        -:  893:    }
        -:  894:
       75:  895:    if (!(scfg->modules &&
        -:  896:          (modp = apr_hash_get(scfg->modules, name, APR_HASH_KEY_STRING)))) {
    #####:  897:        return &PL_sv_undef;
        -:  898:    }
        -:  899:
       75:  900:    if (!(ptr = ap_get_module_config(v, modp))) {
    #####:  901:        return &PL_sv_undef;
        -:  902:    }
        -:  903:
       75:  904:    if (!(table = modperl_module_config_table_get(aTHX_ FALSE))) {
    #####:  905:        return &PL_sv_undef;
        -:  906:    }
        -:  907:
       75:  908:    if (!(obj = modperl_svptr_table_fetch(aTHX_ table, ptr))) {
    #####:  909:        return &PL_sv_undef;
        -:  910:    }
        -:  911:
       75:  912:    return obj;
        -:  913:}