| /* Copyright 2002-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" |
| |
| typedef struct { |
| modperl_mgv_t *dir_create; |
| modperl_mgv_t *dir_merge; |
| modperl_mgv_t *srv_create; |
| modperl_mgv_t *srv_merge; |
| int namelen; |
| } modperl_module_info_t; |
| |
| typedef struct { |
| server_rec *server; |
| modperl_module_info_t *minfo; |
| } modperl_module_cfg_t; |
| |
| #define MP_MODULE_INFO(modp) \ |
| (modperl_module_info_t *)modp->dynamic_load_handle |
| |
| #define MP_MODULE_CFG_MINFO(ptr) \ |
| ((modperl_module_cfg_t *)ptr)->minfo |
| |
| static modperl_module_cfg_t *modperl_module_cfg_new(apr_pool_t *p) |
| { |
| modperl_module_cfg_t *cfg = |
| (modperl_module_cfg_t *)apr_pcalloc(p, sizeof(*cfg)); |
| |
| return cfg; |
| } |
| |
| static modperl_module_cmd_data_t *modperl_module_cmd_data_new(apr_pool_t *p) |
| { |
| modperl_module_cmd_data_t *cmd_data = |
| (modperl_module_cmd_data_t *)apr_pcalloc(p, sizeof(*cmd_data)); |
| |
| return cmd_data; |
| } |
| |
| static void *modperl_module_config_dir_create(apr_pool_t *p, char *dir) |
| { |
| return modperl_module_cfg_new(p); |
| } |
| |
| static void *modperl_module_config_srv_create(apr_pool_t *p, server_rec *s) |
| { |
| return modperl_module_cfg_new(p); |
| } |
| |
| static SV **modperl_module_config_hash_get(pTHX_ int create) |
| { |
| SV **svp; |
| |
| /* XXX: could make this lookup faster */ |
| svp = hv_fetch(PL_modglobal, |
| "ModPerl::Module::ConfigTable", |
| MP_SSTRLEN("ModPerl::Module::ConfigTable"), |
| create); |
| |
| return svp; |
| } |
| |
| void modperl_module_config_table_set(pTHX_ PTR_TBL_t *table) |
| { |
| SV **svp = modperl_module_config_hash_get(aTHX_ TRUE); |
| sv_setiv(*svp, PTR2IV(table)); |
| } |
| |
| PTR_TBL_t *modperl_module_config_table_get(pTHX_ int create) |
| { |
| PTR_TBL_t *table = NULL; |
| |
| SV *sv, **svp = modperl_module_config_hash_get(aTHX_ create); |
| |
| if (!svp) { |
| return NULL; |
| } |
| |
| sv = *svp; |
| if (!SvIOK(sv) && create) { |
| table = modperl_svptr_table_new(aTHX); |
| sv_setiv(sv, PTR2IV(table)); |
| } |
| else { |
| table = INT2PTR(PTR_TBL_t *, SvIV(sv)); |
| } |
| |
| return table; |
| } |
| |
| typedef struct { |
| PerlInterpreter *perl; |
| PTR_TBL_t *table; |
| void *ptr; |
| } config_obj_cleanup_t; |
| |
| /* |
| * any per-dir CREATE or MERGE that happens at request time |
| * needs to be removed from the pointer table. |
| */ |
| static apr_status_t modperl_module_config_obj_cleanup(void *data) |
| { |
| config_obj_cleanup_t *cleanup = |
| (config_obj_cleanup_t *)data; |
| dTHXa(cleanup->perl); |
| |
| modperl_svptr_table_delete(aTHX_ cleanup->table, cleanup->ptr); |
| |
| MP_TRACE_c(MP_FUNC, "deleting ptr 0x%lx from table 0x%lx\n", |
| (unsigned long)cleanup->ptr, |
| (unsigned long)cleanup->table); |
| |
| return APR_SUCCESS; |
| } |
| |
| static void modperl_module_config_obj_cleanup_register(pTHX_ |
| apr_pool_t *p, |
| PTR_TBL_t *table, |
| void *ptr) |
| { |
| config_obj_cleanup_t *cleanup = |
| (config_obj_cleanup_t *)apr_palloc(p, sizeof(*cleanup)); |
| |
| cleanup->table = table; |
| cleanup->ptr = ptr; |
| #ifdef USE_ITHREADS |
| cleanup->perl = aTHX; |
| #endif |
| |
| apr_pool_cleanup_register(p, cleanup, |
| modperl_module_config_obj_cleanup, |
| apr_pool_cleanup_null); |
| } |
| |
| #define MP_CFG_MERGE_DIR 1 |
| #define MP_CFG_MERGE_SRV 2 |
| |
| /* |
| * XXX: vhosts may have different parent interpreters. |
| */ |
| static void *modperl_module_config_merge(apr_pool_t *p, |
| void *basev, void *addv, |
| int type) |
| { |
| GV *gv; |
| modperl_mgv_t *method; |
| modperl_module_cfg_t *mrg = NULL, |
| *tmp, |
| *base = (modperl_module_cfg_t *)basev, |
| *add = (modperl_module_cfg_t *)addv; |
| server_rec *s; |
| int is_startup; |
| PTR_TBL_t *table; |
| SV *mrg_obj = Nullsv, *base_obj, *add_obj; |
| |
| #ifdef USE_ITHREADS |
| modperl_interp_t *interp; |
| pTHX; |
| #endif |
| |
| /* if the module is loaded in vhost, base==NULL */ |
| tmp = (base && base->server) ? base : add; |
| |
| if (tmp && !tmp->server) { |
| /* no directives for this module were encountered so far */ |
| return basev; |
| } |
| |
| s = tmp->server; |
| is_startup = (p == s->process->pconf); |
| |
| #ifdef USE_ITHREADS |
| interp = modperl_interp_pool_select(p, s); |
| aTHX = interp->perl; |
| #endif |
| |
| table = modperl_module_config_table_get(aTHX_ TRUE); |
| base_obj = modperl_svptr_table_fetch(aTHX_ table, base); |
| add_obj = modperl_svptr_table_fetch(aTHX_ table, add); |
| |
| if (!base_obj || (base_obj == add_obj)) { |
| return addv; |
| } |
| |
| mrg = modperl_module_cfg_new(p); |
| memcpy(mrg, tmp, sizeof(*mrg)); |
| |
| method = (type == MP_CFG_MERGE_DIR) ? |
| mrg->minfo->dir_merge : |
| mrg->minfo->srv_merge; |
| |
| if (method && (gv = modperl_mgv_lookup(aTHX_ method))) { |
| int count; |
| dSP; |
| |
| MP_TRACE_c(MP_FUNC, "calling %s->%s\n", |
| SvCLASS(base_obj), modperl_mgv_last_name(method)); |
| |
| ENTER;SAVETMPS; |
| PUSHMARK(sp); |
| XPUSHs(base_obj);XPUSHs(add_obj); |
| |
| PUTBACK; |
| count = call_sv((SV*)GvCV(gv), G_EVAL|G_SCALAR); |
| SPAGAIN; |
| |
| if (count == 1) { |
| mrg_obj = SvREFCNT_inc(POPs); |
| } |
| |
| PUTBACK; |
| FREETMPS;LEAVE; |
| |
| if (SvTRUE(ERRSV)) { |
| /* XXX: should die here. */ |
| (void)modperl_errsv(aTHX_ HTTP_INTERNAL_SERVER_ERROR, |
| NULL, NULL); |
| } |
| } |
| else { |
| mrg_obj = SvREFCNT_inc(add_obj); |
| } |
| |
| modperl_svptr_table_store(aTHX_ table, mrg, mrg_obj); |
| |
| if (!is_startup) { |
| modperl_module_config_obj_cleanup_register(aTHX_ p, table, mrg); |
| } |
| |
| return (void *)mrg; |
| } |
| |
| static void *modperl_module_config_dir_merge(apr_pool_t *p, |
| void *basev, void *addv) |
| { |
| return modperl_module_config_merge(p, basev, addv, |
| MP_CFG_MERGE_DIR); |
| } |
| |
| static void *modperl_module_config_srv_merge(apr_pool_t *p, |
| void *basev, void *addv) |
| { |
| return modperl_module_config_merge(p, basev, addv, |
| MP_CFG_MERGE_SRV); |
| } |
| |
| #define modperl_bless_cmd_parms(parms) \ |
| sv_2mortal(modperl_ptr2obj(aTHX_ "Apache2::CmdParms", (void *)parms)) |
| |
| static const char * |
| modperl_module_config_create_obj(pTHX_ |
| apr_pool_t *p, |
| PTR_TBL_t *table, |
| modperl_module_cfg_t *cfg, |
| modperl_module_cmd_data_t *info, |
| modperl_mgv_t *method, |
| cmd_parms *parms, |
| SV **obj) |
| { |
| const char *mname = info->modp->name; |
| modperl_module_info_t *minfo = MP_MODULE_INFO(info->modp); |
| GV *gv; |
| int is_startup = (p == parms->server->process->pconf); |
| |
| /* |
| * XXX: if MPM is not threaded, we could modify the |
| * modperl_module_cfg_t * directly and avoid the ptr_table |
| * altogether. |
| */ |
| if ((*obj = (SV*)modperl_svptr_table_fetch(aTHX_ table, cfg))) { |
| /* object already exists */ |
| return NULL; |
| } |
| |
| MP_TRACE_c(MP_FUNC, "%s cfg=0x%lx for %s.%s\n", |
| method, (unsigned long)cfg, |
| mname, parms->cmd->name); |
| |
| /* used by merge functions to get a Perl interp */ |
| cfg->server = parms->server; |
| cfg->minfo = minfo; |
| |
| if (method && (gv = modperl_mgv_lookup(aTHX_ method))) { |
| int count; |
| dSP; |
| |
| ENTER;SAVETMPS; |
| PUSHMARK(sp); |
| XPUSHs(sv_2mortal(newSVpv(mname, minfo->namelen))); |
| XPUSHs(modperl_bless_cmd_parms(parms)); |
| |
| PUTBACK; |
| count = call_sv((SV*)GvCV(gv), G_EVAL|G_SCALAR); |
| SPAGAIN; |
| |
| if (count == 1) { |
| *obj = SvREFCNT_inc(POPs); |
| } |
| |
| PUTBACK; |
| FREETMPS;LEAVE; |
| |
| if (SvTRUE(ERRSV)) { |
| return SvPVX(ERRSV); |
| } |
| } |
| else { |
| HV *stash = gv_stashpvn(mname, minfo->namelen, FALSE); |
| /* return bless {}, $class */ |
| *obj = newRV_noinc((SV*)newHV()); |
| *obj = sv_bless(*obj, stash); |
| } |
| |
| if (!is_startup) { |
| modperl_module_config_obj_cleanup_register(aTHX_ p, table, cfg); |
| } |
| |
| modperl_svptr_table_store(aTHX_ table, cfg, *obj); |
| |
| return NULL; |
| } |
| |
| #define PUSH_STR_ARG(arg) \ |
| if (arg) XPUSHs(sv_2mortal(newSVpv(arg,0))) |
| |
| static const char *modperl_module_cmd_take123(cmd_parms *parms, |
| void *mconfig, |
| const char *one, |
| const char *two, |
| const char *three) |
| { |
| modperl_module_cfg_t *cfg = (modperl_module_cfg_t *)mconfig; |
| const char *retval = NULL, *errmsg; |
| const command_rec *cmd = parms->cmd; |
| server_rec *s = parms->server; |
| apr_pool_t *p = parms->pool; |
| modperl_module_cmd_data_t *info = |
| (modperl_module_cmd_data_t *)cmd->cmd_data; |
| modperl_module_info_t *minfo = MP_MODULE_INFO(info->modp); |
| modperl_module_cfg_t *srv_cfg; |
| int modules_alias = 0; |
| |
| #ifdef USE_ITHREADS |
| modperl_interp_t *interp = modperl_interp_pool_select(p, s); |
| dTHXa(interp->perl); |
| #endif |
| |
| int count; |
| PTR_TBL_t *table = modperl_module_config_table_get(aTHX_ TRUE); |
| SV *obj = Nullsv; |
| dSP; |
| |
| if (s->is_virtual) { |
| MP_dSCFG(s); |
| |
| /* if the Perl module is loaded in the base server and a vhost |
| * has configuration directives from that module, but no |
| * mod_perl.c directives, scfg == NULL when |
| * modperl_module_cmd_take123 is run. If the directive |
| * callback wants to do something with the mod_perl config |
| * object, it'll segfault, since it doesn't exist yet, because |
| * this happens before server configs are merged. So we create |
| * a temp struct and fill it in with things that might be |
| * needed by the Perl callback. |
| */ |
| if (!scfg) { |
| scfg = modperl_config_srv_new(p); |
| modperl_set_module_config(s->module_config, scfg); |
| scfg->server = s; |
| } |
| |
| /* if PerlLoadModule Foo is called from the base server, but |
| * Foo's directives are used inside a vhost, we need to |
| * temporary link to the base server config's 'modules' |
| * member. e.g. so Apache2::Module->get_config() can be called |
| * from a custom directive's callback, before the server/vhost |
| * config merge is performed |
| */ |
| if (!scfg->modules) { |
| modperl_config_srv_t *base_scfg = |
| modperl_config_srv_get(modperl_global_get_server_rec()); |
| if (base_scfg->modules) { |
| scfg->modules = base_scfg->modules; |
| modules_alias = 1; |
| } |
| } |
| |
| } |
| |
| errmsg = modperl_module_config_create_obj(aTHX_ p, table, cfg, info, |
| minfo->dir_create, |
| parms, &obj); |
| |
| if (errmsg) { |
| return errmsg; |
| } |
| |
| if (obj) { |
| MP_TRACE_c(MP_FUNC, "found per-dir obj=0x%lx for %s.%s\n", |
| (unsigned long)obj, |
| info->modp->name, cmd->name); |
| } |
| |
| /* XXX: could delay creation of srv_obj until |
| * Apache2::ModuleConfig->get is called. |
| */ |
| srv_cfg = ap_get_module_config(s->module_config, info->modp); |
| |
| if (srv_cfg) { |
| SV *srv_obj; |
| errmsg = modperl_module_config_create_obj(aTHX_ p, table, srv_cfg, info, |
| minfo->srv_create, |
| parms, &srv_obj); |
| if (errmsg) { |
| return errmsg; |
| } |
| |
| if (srv_obj) { |
| MP_TRACE_c(MP_FUNC, "found per-srv obj=0x%lx for %s.%s\n", |
| (unsigned long)srv_obj, |
| info->modp->name, cmd->name); |
| } |
| } |
| |
| ENTER;SAVETMPS; |
| PUSHMARK(SP); |
| EXTEND(SP, 2); |
| |
| PUSHs(obj); |
| PUSHs(modperl_bless_cmd_parms(parms)); |
| |
| if (cmd->args_how != NO_ARGS) { |
| PUSH_STR_ARG(one); |
| PUSH_STR_ARG(two); |
| PUSH_STR_ARG(three); |
| } |
| |
| PUTBACK; |
| count = call_method(info->func_name, G_EVAL|G_SCALAR); |
| SPAGAIN; |
| |
| if (count == 1) { |
| SV *sv = POPs; |
| if (SvPOK(sv) && strEQ(SvPVX(sv), DECLINE_CMD)) { |
| retval = DECLINE_CMD; |
| } |
| } |
| |
| PUTBACK; |
| FREETMPS;LEAVE; |
| |
| if (SvTRUE(ERRSV)) { |
| retval = SvPVX(ERRSV); |
| } |
| |
| if (modules_alias) { |
| MP_dSCFG(s); |
| /* unalias the temp aliasing */ |
| scfg->modules = NULL; |
| } |
| |
| return retval; |
| } |
| |
| static const char *modperl_module_cmd_take1(cmd_parms *parms, |
| void *mconfig, |
| const char *one) |
| { |
| return modperl_module_cmd_take123(parms, mconfig, one, NULL, NULL); |
| } |
| |
| static const char *modperl_module_cmd_take2(cmd_parms *parms, |
| void *mconfig, |
| const char *one, |
| const char *two) |
| { |
| return modperl_module_cmd_take123(parms, mconfig, one, two, NULL); |
| } |
| |
| static const char *modperl_module_cmd_flag(cmd_parms *parms, |
| void *mconfig, |
| int flag) |
| { |
| char buf[2]; |
| |
| apr_snprintf(buf, sizeof(buf), "%d", flag); |
| |
| return modperl_module_cmd_take123(parms, mconfig, buf, NULL, NULL); |
| } |
| |
| static const char *modperl_module_cmd_no_args(cmd_parms *parms, |
| void *mconfig) |
| { |
| return modperl_module_cmd_take123(parms, mconfig, NULL, NULL, NULL); |
| } |
| |
| #define modperl_module_cmd_raw_args modperl_module_cmd_take1 |
| #define modperl_module_cmd_iterate modperl_module_cmd_take1 |
| #define modperl_module_cmd_iterate2 modperl_module_cmd_take2 |
| #define modperl_module_cmd_take12 modperl_module_cmd_take2 |
| #define modperl_module_cmd_take23 modperl_module_cmd_take123 |
| #define modperl_module_cmd_take3 modperl_module_cmd_take123 |
| #define modperl_module_cmd_take13 modperl_module_cmd_take123 |
| |
| #if defined(AP_HAVE_DESIGNATED_INITIALIZER) |
| # define modperl_module_cmd_func_set(cmd, name) \ |
| cmd->func.name = modperl_module_cmd_##name |
| #else |
| # define modperl_module_cmd_func_set(cmd, name) \ |
| cmd->func = modperl_module_cmd_##name |
| #endif |
| |
| static int modperl_module_cmd_lookup(command_rec *cmd) |
| { |
| switch (cmd->args_how) { |
| case TAKE1: |
| case ITERATE: |
| modperl_module_cmd_func_set(cmd, take1); |
| break; |
| case TAKE2: |
| case ITERATE2: |
| case TAKE12: |
| modperl_module_cmd_func_set(cmd, take2); |
| break; |
| case TAKE3: |
| case TAKE23: |
| case TAKE123: |
| case TAKE13: |
| modperl_module_cmd_func_set(cmd, take3); |
| break; |
| case RAW_ARGS: |
| modperl_module_cmd_func_set(cmd, raw_args); |
| break; |
| case FLAG: |
| modperl_module_cmd_func_set(cmd, flag); |
| break; |
| case NO_ARGS: |
| modperl_module_cmd_func_set(cmd, no_args); |
| break; |
| default: |
| return FALSE; |
| } |
| |
| return TRUE; |
| } |
| |
| static apr_status_t modperl_module_remove(void *data) |
| { |
| module *modp = (module *)data; |
| |
| ap_remove_loaded_module(modp); |
| |
| return APR_SUCCESS; |
| } |
| |
| static const char *modperl_module_cmd_fetch(pTHX_ SV *obj, |
| const char *name, SV **retval) |
| { |
| const char *errmsg = NULL; |
| |
| if (*retval) { |
| SvREFCNT_dec(*retval); |
| *retval = Nullsv; |
| } |
| |
| if (sv_isobject(obj)) { |
| int count; |
| dSP; |
| ENTER;SAVETMPS; |
| PUSHMARK(SP); |
| XPUSHs(obj); |
| PUTBACK; |
| |
| count = call_method(name, G_EVAL|G_SCALAR); |
| |
| SPAGAIN; |
| |
| if (count == 1) { |
| SV *sv = POPs; |
| if (SvTRUE(sv)) { |
| *retval = SvREFCNT_inc(sv); |
| } |
| } |
| |
| if (!*retval) { |
| errmsg = Perl_form(aTHX_ "%s->%s did not return a %svalue", |
| SvCLASS(obj), name, count ? "true " : ""); |
| } |
| |
| PUTBACK; |
| FREETMPS;LEAVE; |
| |
| if (SvTRUE(ERRSV)) { |
| errmsg = SvPVX(ERRSV); |
| } |
| } |
| else if (SvROK(obj) && (SvTYPE(SvRV(obj)) == SVt_PVHV)) { |
| HV *hv = (HV*)SvRV(obj); |
| SV **svp = hv_fetch(hv, name, strlen(name), 0); |
| |
| if (svp) { |
| *retval = SvREFCNT_inc(*svp); |
| } |
| else { |
| errmsg = Perl_form(aTHX_ "HASH key %s does not exist", name); |
| } |
| } |
| else { |
| errmsg = "command entry is not an object or a HASH reference"; |
| } |
| |
| return errmsg; |
| } |
| |
| static const char *modperl_module_add_cmds(apr_pool_t *p, server_rec *s, |
| module *modp, SV *mod_cmds) |
| { |
| const char *errmsg; |
| apr_array_header_t *cmds; |
| command_rec *cmd; |
| AV *module_cmds; |
| I32 i, fill; |
| #ifdef USE_ITHREADS |
| MP_dSCFG(s); |
| dTHXa(scfg->mip->parent->perl); |
| #endif |
| module_cmds = (AV*)SvRV(mod_cmds); |
| |
| fill = AvFILL(module_cmds); |
| cmds = apr_array_make(p, fill+1, sizeof(command_rec)); |
| |
| for (i=0; i<=fill; i++) { |
| SV *val = Nullsv; |
| STRLEN len; |
| SV *obj = AvARRAY(module_cmds)[i]; |
| modperl_module_cmd_data_t *info = modperl_module_cmd_data_new(p); |
| |
| info->modp = modp; |
| |
| cmd = apr_array_push(cmds); |
| |
| if ((errmsg = modperl_module_cmd_fetch(aTHX_ obj, "name", &val))) { |
| return errmsg; |
| } |
| |
| cmd->name = apr_pstrdup(p, SvPV(val, len)); |
| |
| if ((errmsg = modperl_module_cmd_fetch(aTHX_ obj, "args_how", &val))) { |
| /* XXX default based on $self->func prototype */ |
| cmd->args_how = TAKE1; /* default */ |
| } |
| else { |
| if (SvIOK(val)) { |
| cmd->args_how = SvIV(val); |
| } |
| else { |
| cmd->args_how = |
| SvIV(modperl_constants_lookup_apache2(aTHX_ SvPV(val, len))); |
| } |
| } |
| |
| if (!modperl_module_cmd_lookup(cmd)) { |
| return apr_psprintf(p, |
| "no command function defined for args_how=%d", |
| cmd->args_how); |
| } |
| |
| if ((errmsg = modperl_module_cmd_fetch(aTHX_ obj, "func", &val))) { |
| info->func_name = cmd->name; /* default */ |
| } |
| else { |
| info->func_name = apr_pstrdup(p, SvPV(val, len)); |
| } |
| |
| if ((errmsg = modperl_module_cmd_fetch(aTHX_ obj, "req_override", &val))) { |
| cmd->req_override = OR_ALL; /* default */ |
| } |
| else { |
| if (SvIOK(val)) { |
| cmd->req_override = SvIV(val); |
| } |
| else { |
| cmd->req_override = |
| SvIV(modperl_constants_lookup_apache2(aTHX_ SvPV(val, len))); |
| } |
| } |
| |
| if ((errmsg = modperl_module_cmd_fetch(aTHX_ obj, "errmsg", &val))) { |
| /* default */ |
| /* XXX generate help msg based on args_how */ |
| cmd->errmsg = apr_pstrcat(p, cmd->name, " command", NULL); |
| } |
| else { |
| cmd->errmsg = apr_pstrdup(p, SvPV(val, len)); |
| } |
| |
| cmd->cmd_data = info; |
| |
| /* no default if undefined */ |
| if (!(errmsg = modperl_module_cmd_fetch(aTHX_ obj, "cmd_data", &val))) { |
| info->cmd_data = apr_pstrdup(p, SvPV(val, len)); |
| } |
| |
| if (val) { |
| SvREFCNT_dec(val); |
| val = Nullsv; |
| } |
| } |
| |
| cmd = apr_array_push(cmds); |
| cmd->name = NULL; |
| |
| modp->cmds = (command_rec *)cmds->elts; |
| |
| return NULL; |
| } |
| |
| static void modperl_module_insert(module *modp) |
| { |
| module *m; |
| |
| /* |
| * insert after mod_perl, rather the top of the list. |
| * (see ap_add_module; does not insert into ap_top_module list if |
| * m->next != NULL) |
| * this way, modperl config merging happens before this module. |
| */ |
| |
| for (m = ap_top_module; m; m=m->next) { |
| if (m == &perl_module) { |
| module *next = m->next; |
| m->next = modp; |
| modp->next = next; |
| break; |
| } |
| } |
| } |
| |
| #define MP_isGV(gv) (gv && isGV(gv)) |
| |
| static modperl_mgv_t *modperl_module_fetch_method(pTHX_ |
| apr_pool_t *p, |
| module *modp, |
| const char *method) |
| { |
| modperl_mgv_t *mgv; |
| |
| HV *stash = gv_stashpv(modp->name, FALSE); |
| GV *gv = gv_fetchmethod_autoload(stash, method, FALSE); |
| |
| MP_TRACE_c(MP_FUNC, "looking for method %s in package `%s'...%sfound\n", |
| method, modp->name, |
| MP_isGV(gv) ? "" : "not "); |
| |
| if (!MP_isGV(gv)) { |
| return NULL; |
| } |
| |
| mgv = modperl_mgv_compile(aTHX_ p, |
| apr_pstrcat(p, |
| modp->name, "::", method, NULL)); |
| |
| return mgv; |
| } |
| |
| const char *modperl_module_add(apr_pool_t *p, server_rec *s, |
| const char *name, SV *mod_cmds) |
| { |
| MP_dSCFG(s); |
| #ifdef USE_ITHREADS |
| dTHXa(scfg->mip->parent->perl); |
| #endif |
| const char *errmsg; |
| module *modp = (module *)apr_pcalloc(p, sizeof(*modp)); |
| modperl_module_info_t *minfo = |
| (modperl_module_info_t *)apr_pcalloc(p, sizeof(*minfo)); |
| |
| /* STANDARD20_MODULE_STUFF */ |
| modp->version = MODULE_MAGIC_NUMBER_MAJOR; |
| modp->minor_version = MODULE_MAGIC_NUMBER_MINOR; |
| modp->module_index = -1; |
| modp->name = apr_pstrdup(p, name); |
| modp->magic = MODULE_MAGIC_COOKIE; |
| |
| /* use this slot for our context */ |
| modp->dynamic_load_handle = minfo; |
| |
| /* |
| * XXX: we should lookup here if the Perl methods exist, |
| * and set these pointers only if they do. |
| */ |
| modp->create_dir_config = modperl_module_config_dir_create; |
| modp->merge_dir_config = modperl_module_config_dir_merge; |
| modp->create_server_config = modperl_module_config_srv_create; |
| modp->merge_server_config = modperl_module_config_srv_merge; |
| |
| minfo->namelen = strlen(name); |
| |
| minfo->dir_create = |
| modperl_module_fetch_method(aTHX_ p, modp, "DIR_CREATE"); |
| |
| minfo->dir_merge = |
| modperl_module_fetch_method(aTHX_ p, modp, "DIR_MERGE"); |
| |
| minfo->srv_create = |
| modperl_module_fetch_method(aTHX_ p, modp, "SERVER_CREATE"); |
| |
| minfo->srv_merge = |
| modperl_module_fetch_method(aTHX_ p, modp, "SERVER_MERGE"); |
| |
| modp->cmds = NULL; |
| |
| if ((errmsg = modperl_module_add_cmds(p, s, modp, mod_cmds))) { |
| return errmsg; |
| } |
| |
| modperl_module_insert(modp); |
| |
| ap_add_loaded_module(modp, p); |
| |
| apr_pool_cleanup_register(p, modp, modperl_module_remove, |
| apr_pool_cleanup_null); |
| |
| ap_single_module_configure(p, s, modp); |
| |
| if (!scfg->modules) { |
| scfg->modules = apr_hash_make(p); |
| } |
| |
| apr_hash_set(scfg->modules, apr_pstrdup(p, name), APR_HASH_KEY_STRING, modp); |
| |
| #ifdef USE_ITHREADS |
| /* |
| * if the Perl module is loaded in the base server and a vhost |
| * has configuration directives from that module, but no mod_perl.c |
| * directives, scfg == NULL when modperl_module_cmd_take123 is run. |
| * this happens before server configs are merged, so we stash a pointer |
| * to what will be merged as the parent interp later. i.e. "safe hack" |
| */ |
| if (!modperl_interp_pool_get(p)) { |
| /* for vhosts */ |
| modperl_interp_pool_set(p, scfg->mip->parent, FALSE); |
| } |
| #endif |
| |
| return NULL; |
| } |
| |
| SV *modperl_module_config_get_obj(pTHX_ SV *pmodule, server_rec *s, |
| ap_conf_vector_t *v) |
| { |
| MP_dSCFG(s); |
| module *modp; |
| const char *name; |
| void *ptr; |
| PTR_TBL_t *table; |
| SV *obj; |
| |
| if (!v) { |
| v = s->module_config; |
| } |
| |
| if (SvROK(pmodule)) { |
| name = SvCLASS(pmodule); |
| } |
| else { |
| STRLEN n_a; |
| name = SvPV(pmodule, n_a); |
| } |
| |
| if (!(scfg->modules && |
| (modp = apr_hash_get(scfg->modules, name, APR_HASH_KEY_STRING)))) { |
| return &PL_sv_undef; |
| } |
| |
| if (!(ptr = ap_get_module_config(v, modp))) { |
| return &PL_sv_undef; |
| } |
| |
| if (!(table = modperl_module_config_table_get(aTHX_ FALSE))) { |
| return &PL_sv_undef; |
| } |
| |
| if (!(obj = modperl_svptr_table_fetch(aTHX_ table, ptr))) { |
| return &PL_sv_undef; |
| } |
| |
| return obj; |
| } |