cvs commit: modperl-2.0/src/modules/perl modperl_perl.c modperl_perl.h
dougm 2002/08/26 18:46:27
Modified:src/modules/perl modperl_perl.c modperl_perl.h
Log:
modperl_svptr_table api is an add-on to the Perl ptr_table_ api.
we use a PTR_TBL_t to map config structures (e.g. from parsed
httpd.conf or .htaccess), where each interpreter needs to have its
own copy of the Perl SV object. we do not use an HV* for this, because
the HV keys must be SVs with a string value, too much overhead.
we do not use an apr_hash_t because they only have the lifetime of
the pool used to create them. which may or may not be the same lifetime
of the objects we need to lookup.
Revision ChangesPath
1.15 +123 -0modperl-2.0/src/modules/perl/modperl_perl.c
Index: modperl_perl.c
===
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_perl.c,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -r1.14 -r1.15
--- modperl_perl.c27 May 2002 18:41:52 - 1.14
+++ modperl_perl.c27 Aug 2002 01:46:27 - 1.15
-137,3 +137,126
}
#endif
}
+
+/*
+ * modperl_svptr_table api is an add-on to the Perl ptr_table_ api.
+ * we use a PTR_TBL_t to map config structures (e.g. from parsed
+ * httpd.conf or .htaccess), where each interpreter needs to have its
+ * own copy of the Perl SV object. we do not use an HV* for this, because
+ * the HV keys must be SVs with a string value, too much overhead.
+ * we do not use an apr_hash_t because they only have the lifetime of
+ * the pool used to create them. which may or may not be the same lifetime
+ * of the objects we need to lookup.
+ */
+
+#ifdef USE_ITHREADS
+
+/*
+ * copy a PTR_TBL_t whos PTR_TBL_ENT_t values are SVs.
+ * the SVs are dup-ed so each interpreter has its own copy.
+ */
+PTR_TBL_t *modperl_svptr_table_clone(pTHX_ PerlInterpreter *proto_perl,
+ PTR_TBL_t *source)
+{
+UV i;
+PTR_TBL_t *tbl;
+PTR_TBL_ENT_t **src_ary, **dst_ary;
+CLONE_PARAMS parms;
+
+Newz(0, tbl, 1, PTR_TBL_t);
+tbl-tbl_max = source-tbl_max;
+tbl-tbl_items = source-tbl_items;
+Newz(0, tbl-tbl_ary, tbl-tbl_max + 1, PTR_TBL_ENT_t *);
+
+dst_ary = tbl-tbl_ary;
+src_ary = source-tbl_ary;
+
+Zero(parms, 0, CLONE_PARAMS);
+parms.flags = 0;
+parms.stashes = newAV();
+
+for (i=0; i source-tbl_max; i++, dst_ary++, src_ary++) {
+ PTR_TBL_ENT_t *src_ent, *dst_ent=NULL;
+
+ if (!*src_ary) {
+ continue;
+}
+
+ for (src_ent = *src_ary;
+ src_ent;
+ src_ent = src_ent-next)
+{
+if (dst_ent == NULL) {
+Newz(0, dst_ent, 1, PTR_TBL_ENT_t);
+*dst_ary = dst_ent;
+}
+else {
+Newz(0, dst_ent-next, 1, PTR_TBL_ENT_t);
+dst_ent = dst_ent-next;
+}
+
+/* key is just a pointer we do not modify, no need to copy */
+dst_ent-oldval = src_ent-oldval;
+
+dst_ent-newval =
+SvREFCNT_inc(sv_dup((SV*)src_ent-newval, parms));
+}
+}
+
+SvREFCNT_dec(parms.stashes);
+
+return tbl;
+}
+
+/*
+ * need to free the SV values in addition to ptr_table_free
+ */
+void modperl_svptr_table_destroy(pTHX_ PTR_TBL_t *tbl)
+{
+UV i;
+PTR_TBL_ENT_t **ary = tbl-tbl_ary;
+
+for (i=0; i tbl-tbl_max; i++, ary++) {
+ PTR_TBL_ENT_t *ent;
+
+ if (!*ary) {
+ continue;
+}
+
+ for (ent = *ary; ent; ent = ent-next) {
+if (!ent-newval) {
+continue;
+}
+
+SvREFCNT_dec((SV*)ent-newval);
+ent-newval = NULL;
+}
+}
+
+ptr_table_free(tbl);
+}
+#endif
+
+/*
+ * the Perl ptr_table_ api does not provide a function to remove
+ * an entry from the table. we need to SvREFCNT_dec the SV value
+ * anyhow.
+ */
+void modperl_svptr_table_delete(pTHX_ PTR_TBL_t *tbl, void *key)
+{
+PTR_TBL_ENT_t *entry, **oentry;
+UV hash = PTR2UV(key);
+
+oentry = tbl-tbl_ary[hash tbl-tbl_max];
+entry = *oentry;
+
+for (; entry; oentry = entry-next, entry = *oentry) {
+ if (entry-oldval == key) {
+*oentry = entry-next;
+SvREFCNT_dec((SV*)entry-newval);
+Safefree(entry);
+tbl-tbl_items--;
+ return;
+ }
+}
+}
1.8 +11 -0 modperl-2.0/src/modules/perl/modperl_perl.h
Index: modperl_perl.h
===
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_perl.h,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
---
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 ChangesPath
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));
