You are viewing a plain text version of this content. The canonical link for it is here.
Posted to modperl-cvs@perl.apache.org by do...@apache.org on 2002/08/27 06:21:21 UTC
cvs commit: modperl-2.0/src/modules/perl modperl_module.c modperl_module.h
dougm 2002/08/26 21:21:20
Added: src/modules/perl modperl_module.c modperl_module.h
Log:
module to create an apache module on the fly to support directive handlers
Revision Changes Path
1.1 modperl-2.0/src/modules/perl/modperl_module.c
Index: modperl_module.c
===================================================================
#include "mod_perl.h"
typedef struct {
server_rec *server;
const char *name;
int namelen;
} modperl_module_cfg_t;
typedef struct {
module *modp;
const char *cmd_data;
const char *func_name;
} modperl_module_cmd_data_t;
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, (IV)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 = ptr_table_new();
sv_setiv(sv, (IV)table);
}
else {
table = (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);
}
static void *modperl_module_config_merge(apr_pool_t *p,
void *basev, void *addv,
const char *method)
{
GV *gv;
modperl_module_cfg_t *mrg = NULL,
*base = (modperl_module_cfg_t *)basev,
*add = (modperl_module_cfg_t *)addv,
*tmp = base->server ? base : add;
server_rec *s = tmp->server;
int is_startup = (p == s->process->pconf);
#ifdef USE_ITHREADS
modperl_interp_t *interp = modperl_interp_pool_select(p, s);
dTHXa(interp->perl);
#endif
PTR_TBL_t *table = modperl_module_config_table_get(aTHX_ TRUE);
SV *mrg_obj = Nullsv,
*base_obj = ptr_table_fetch(table, base),
*add_obj = ptr_table_fetch(table, add);
HV *stash;
if (!base_obj || (base_obj == add_obj)) {
return add_obj;
}
stash = SvSTASH(SvRV(base_obj));
MP_TRACE_c(MP_FUNC, "looking for method %s in package `%s'\n",
method, SvCLASS(base_obj));
/* XXX: should do this lookup at startup time */
if ((gv = gv_fetchmethod_autoload(stash, method, FALSE)) && isGV(gv)) {
int count;
dSP;
mrg = modperl_module_cfg_new(p);
memcpy(mrg, tmp, sizeof(*mrg));
MP_TRACE_c(MP_FUNC, "calling %s->%s\n", SvCLASS(base_obj), 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 = newSVsv(base_obj);
}
ptr_table_store(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, "DIR_MERGE");
}
static void *modperl_module_config_srv_merge(apr_pool_t *p,
void *basev, void *addv)
{
return modperl_module_config_merge(p, basev, addv, "SERVER_MERGE");
}
#define modperl_bless_cmd_parms(parms) \
sv_2mortal(modperl_ptr2obj(aTHX_ "Apache::CmdParms", (void *)parms))
static const char *
modperl_module_config_get_obj(pTHX_
apr_pool_t *p,
PTR_TBL_t *table,
modperl_module_cfg_t *cfg,
modperl_module_cmd_data_t *info,
const char *method,
cmd_parms *parms,
SV **obj)
{
HV *stash;
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*)ptr_table_fetch(table, cfg))) {
/* object already exists */
return NULL;
}
MP_TRACE_c(MP_FUNC, "%s cfg=0x%lx for %s.%s\n",
method, (unsigned long)cfg,
info->modp->name,
parms->cmd->name);
cfg->name = info->modp->name;
cfg->namelen = strlen(cfg->name);
/* used by merge functions to get a Perl interp */
cfg->server = parms->server;
stash = gv_stashpvn(cfg->name, cfg->namelen, TRUE);
/* return $class->type if $class->can(type) */
/* XXX: should do this lookup at startup time */
if ((gv = gv_fetchmethod_autoload(stash, method, FALSE)) && isGV(gv)) {
int count;
dSP;
ENTER;SAVETMPS;
PUSHMARK(sp);
XPUSHs(sv_2mortal(newSVpv(cfg->name, cfg->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 {
/* 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);
}
ptr_table_store(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,
modperl_module_cfg_t *cfg,
const char *one,
const char *two,
const char *three)
{
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_cfg_t *srv_cfg;
#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;
errmsg = modperl_module_config_get_obj(aTHX_ p, table, cfg, info,
"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
* Apache::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_get_obj(aTHX_ p, table, srv_cfg, info,
"SERVER_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) {
if (strEQ(POPp, DECLINE_CMD)) {
retval = DECLINE_CMD;
}
}
PUTBACK;
FREETMPS;LEAVE;
if (SvTRUE(ERRSV)) {
retval = SvPVX(ERRSV);
}
return retval;
}
static const char *modperl_module_cmd_TAKE1(cmd_parms *parms,
modperl_module_cfg_t *cfg,
const char *one)
{
return modperl_module_cmd_TAKE123(parms, cfg, one, NULL, NULL);
}
static const char *modperl_module_cmd_TAKE2(cmd_parms *parms,
modperl_module_cfg_t *cfg,
const char *one,
const char *two)
{
return modperl_module_cmd_TAKE123(parms, cfg, one, two, NULL);
}
static const char *modperl_module_cmd_FLAG(cmd_parms *parms,
modperl_module_cfg_t *cfg,
int flag)
{
char buf[2];
apr_snprintf(buf, sizeof(buf), "%d", flag);
return modperl_module_cmd_TAKE123(parms, cfg, buf, NULL, NULL);
}
#define modperl_module_cmd_RAW_ARGS modperl_module_cmd_TAKE1
#define modperl_module_cmd_NO_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
static cmd_func modperl_module_cmd_lookup(enum cmd_how args_how) {
switch (args_how) {
case RAW_ARGS:
return modperl_module_cmd_RAW_ARGS;
case TAKE1:
return modperl_module_cmd_TAKE1;
case TAKE2:
return modperl_module_cmd_TAKE2;
case ITERATE:
return modperl_module_cmd_ITERATE;
case ITERATE2:
return modperl_module_cmd_ITERATE2;
case FLAG:
return modperl_module_cmd_FLAG;
case NO_ARGS:
return modperl_module_cmd_NO_ARGS;
case TAKE12:
return modperl_module_cmd_TAKE12;
case TAKE3:
return modperl_module_cmd_TAKE3;
case TAKE23:
return modperl_module_cmd_TAKE23;
case TAKE123:
return modperl_module_cmd_TAKE123;
case TAKE13:
return modperl_module_cmd_TAKE13;
}
return NULL;
}
static apr_status_t modperl_module_remove(void *data)
{
module *modp = (module *)data;
ap_remove_loaded_module(modp);
return APR_SUCCESS;
}
static AV *modperl_module_cmds_get(pTHX_ module *modp)
{
char *name = Perl_form(aTHX_ "%s::%s", modp->name,
"APACHE_MODULE_COMMANDS");
return get_av(name, FALSE);
}
static const char *modperl_module_cmd_fetch(pTHX_ SV *obj,
const char *name, SV **retval)
{
const char *errmsg = NULL;
*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)
{
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
if (!(module_cmds = modperl_module_cmds_get(aTHX_ modp))) {
return apr_pstrcat(p, "module ", modp->name,
" does not define @APACHE_MODULE_COMMANDS", NULL);
}
fill = AvFILL(module_cmds);
cmds = apr_array_make(p, fill+1, sizeof(command_rec));
for (i=0; i<=fill; i++) {
SV *val;
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));
SvREFCNT_dec(val);
if ((errmsg = modperl_module_cmd_fetch(aTHX_ obj, "args_how", &val))) {
/* XXX default based on $self->func prototype */
cmd->args_how = TAKE1; /* default */
}
else {
cmd->args_how = SvIV(val);
SvREFCNT_dec(val);
}
if (!(cmd->func = modperl_module_cmd_lookup(cmd->args_how))) {
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));
SvREFCNT_dec(val);
}
if ((errmsg = modperl_module_cmd_fetch(aTHX_ obj, "req_override", &val))) {
cmd->req_override = OR_ALL; /* default */
}
else {
cmd->req_override = SvIV(val);
SvREFCNT_dec(val);
}
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));
SvREFCNT_dec(val);
}
cmd->cmd_data = info;
/* no default if undefined */
if (!(errmsg = modperl_module_cmd_fetch(aTHX_ obj, "data", &val))) {
info->cmd_data = apr_pstrdup(p, SvPV(val, len));
SvREFCNT_dec(val);
}
}
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;
}
}
}
const char *modperl_module_add(apr_pool_t *p, server_rec *s,
const char *name)
{
MP_dSCFG(s);
const char *errmsg;
module *modp = (module *)apr_pcalloc(p, sizeof(*modp));
/* 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;
/*
* 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;
modp->cmds = NULL;
if ((errmsg = modperl_module_add_cmds(p, s, modp))) {
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, 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;
}
1.1 modperl-2.0/src/modules/perl/modperl_module.h
Index: modperl_module.h
===================================================================
#ifndef MODPERL_MODULE_H
#define MODPERL_MODULE_H
PTR_TBL_t *modperl_module_config_table_get(pTHX_ int create);
void modperl_module_config_table_set(pTHX_ PTR_TBL_t *table);
const char *modperl_module_add(apr_pool_t *p, server_rec *s,
const char *name);
#endif /* MODPERL_MODULE_H */