On Tuesday 25 September 2007 15:52, Torsten Foertsch wrote: > It may have flaws with other resources. For example > I think pnotes need to be dropped whenever an interpreter is freed. I still > have to check that.
This is an update to the yesterday patch. It cures a problem that occurred to me last night. In modperl_callback_run_handlers() there is this comment: - /* XXX: would like to do this in modperl_hook_create_request() - * but modperl_interp_select() is what figures out if - * PerlInterpScope eq handler, in which case we do not register - * a cleanup. modperl_hook_create_request() is also currently always - * run even if modperl isn't handling any part of the request - */ - modperl_config_req_cleanup_register(r, rcfg); This is the place where the function that calls a PerlCleanupHandler is registered. It occurred to me that modperl_callback_run_handlers() is called only if at least one Perl*Handler is called in the request cycle. So a PerlCleanupHandler cannot be called unless there is an other Perl*Handler previously called in the same request cycle. On top of the interpreter allocation patch it is very easy to fix that. Simply do what the comment suggests. The attached "x" adds a test case for the bug. The attached trunk-threads.patch contains the fix plus the test case. Torsten
Index: src/modules/perl/modperl_module.c
===================================================================
--- src/modules/perl/modperl_module.c (revision 578102)
+++ src/modules/perl/modperl_module.c (working copy)
@@ -193,8 +193,9 @@
if (!base_obj || (base_obj == add_obj)) {
#ifdef USE_ITHREADS
- /* XXX: breaks prefork
- modperl_interp_unselect(interp); */
+ MP_TRACE_i(MP_FUNC, "unselecting: (0x%lx)->refcnt=%ld\n",
+ interp, interp->refcnt);
+ modperl_interp_unselect(interp);
MP_PERL_CONTEXT_RESTORE;
#endif
return addv;
@@ -246,8 +247,9 @@
}
#ifdef USE_ITHREADS
- /* XXX: breaks prefork
- modperl_interp_unselect(interp); */
+ MP_TRACE_i(MP_FUNC, "unselecting: (0x%lx)->refcnt=%ld\n",
+ interp, interp->refcnt);
+ modperl_interp_unselect(interp);
MP_PERL_CONTEXT_RESTORE;
#endif
@@ -416,6 +418,11 @@
parms, &obj);
if (errmsg) {
+#ifdef USE_ITHREADS
+ MP_TRACE_i(MP_FUNC, "unselecting: (0x%lx)->refcnt=%ld\n",
+ interp, interp->refcnt);
+ modperl_interp_unselect(interp);
+#endif
return errmsg;
}
@@ -436,6 +443,11 @@
minfo->srv_create,
parms, &srv_obj);
if (errmsg) {
+#ifdef USE_ITHREADS
+ MP_TRACE_i(MP_FUNC, "unselecting: (0x%lx)->refcnt=%ld\n",
+ interp, interp->refcnt);
+ modperl_interp_unselect(interp);
+#endif
return errmsg;
}
@@ -477,6 +489,12 @@
retval = SvPVX(ERRSV);
}
+#ifdef USE_ITHREADS
+ MP_TRACE_i(MP_FUNC, "unselecting: (0x%lx)->refcnt=%ld\n",
+ interp, interp->refcnt);
+ modperl_interp_unselect(interp);
+#endif
+
if (modules_alias) {
MP_dSCFG(s);
/* unalias the temp aliasing */
@@ -863,7 +881,9 @@
*/
if (!modperl_interp_pool_get(p)) {
/* for vhosts */
- modperl_interp_pool_set(p, scfg->mip->parent, FALSE);
+ MP_TRACE_i(MP_FUNC, "set interp 0x%lx in pconf pool 0x%lx\n",
+ (unsigned long)scfg->mip->parent, (unsigned long)p);
+ modperl_interp_pool_set(p, scfg->mip->parent);
}
#endif
@@ -911,3 +931,9 @@
return obj;
}
+
+/*
+ * Local Variables:
+ * c-basic-offset: 4
+ * End:
+ */
Index: src/modules/perl/modperl_common_log.c
===================================================================
--- src/modules/perl/modperl_common_log.c (revision 578102)
+++ src/modules/perl/modperl_common_log.c (working copy)
@@ -49,7 +49,7 @@
}
if (func) {
- apr_file_printf(logfile, "%s: ", func);
+ apr_file_printf(logfile, "%d: %s: ", getpid(), func);
}
va_start(args, fmt);
Index: src/modules/perl/mod_perl.c
===================================================================
--- src/modules/perl/mod_perl.c (revision 578102)
+++ src/modules/perl/mod_perl.c (working copy)
@@ -612,8 +612,6 @@
return OK;
}
- MP_TRACE_i(MP_FUNC, "mod_perl hook init\n");
-
MP_init_status = 1; /* now starting */
modperl_restart_count_inc(s);
@@ -737,7 +735,16 @@
{
MP_dRCFG;
+#ifdef USE_ITHREADS
+ if (modperl_threaded_mpm()) {
+ MP_TRACE_i(MP_FUNC, "setting userdata MODPERL_R in pool %#lx to %lx\n",
+ (unsigned long)r->pool, (unsigned long)r);
+ (void)apr_pool_userdata_set((void *)r, "MODPERL_R", NULL, r->pool);
+ }
+#endif
+
modperl_config_req_init(r, rcfg);
+ modperl_config_req_cleanup_register(r, rcfg);
/* set the default for cgi header parsing On as early as possible
* so $r->content_type in any phase after header_parser could turn
@@ -751,6 +758,12 @@
static int modperl_hook_post_read_request(request_rec *r)
{
+#ifdef USE_ITHREADS
+ MP_TRACE_i(MP_FUNC, "%s %s:%d%s\n",
+ r->method, r->connection->local_addr->hostname,
+ r->connection->local_addr->port, r->unparsed_uri);
+#endif
+
/* if 'PerlOptions +GlobalRequest' is outside a container */
modperl_global_request_cfg_set(r);
@@ -1015,7 +1028,6 @@
int modperl_response_handler(request_rec *r)
{
MP_dDCFG;
- MP_dRCFG;
apr_status_t retval;
#ifdef USE_ITHREADS
@@ -1029,10 +1041,9 @@
#ifdef USE_ITHREADS
interp = modperl_interp_select(r, r->connection, r->server);
+ MP_TRACE_i(MP_FUNC, "just selected: (0x%lx)->refcnt=%ld\n",
+ interp, interp->refcnt);
aTHX = interp->perl;
- if (MpInterpPUTBACK(interp)) {
- rcfg->interp = interp;
- }
#endif
/* default is -SetupEnv, add if PerlOption +SetupEnv */
@@ -1043,11 +1054,9 @@
retval = modperl_response_handler_run(r, TRUE);
#ifdef USE_ITHREADS
- if (MpInterpPUTBACK(interp)) {
- /* PerlInterpScope handler */
- rcfg->interp = NULL;
- modperl_interp_unselect(interp);
- }
+ MP_TRACE_i(MP_FUNC, "unselecting: (0x%lx)->refcnt=%ld\n",
+ interp, interp->refcnt);
+ modperl_interp_unselect(interp);
#endif
return retval;
@@ -1070,10 +1079,9 @@
#ifdef USE_ITHREADS
interp = modperl_interp_select(r, r->connection, r->server);
+ MP_TRACE_i(MP_FUNC, "just selected: (0x%lx)->refcnt=%ld\n",
+ interp, interp->refcnt);
aTHX = interp->perl;
- if (MpInterpPUTBACK(interp)) {
- rcfg->interp = interp;
- }
#endif
modperl_perl_global_request_save(aTHX_ r);
@@ -1107,11 +1115,9 @@
FREETMPS;LEAVE;
#ifdef USE_ITHREADS
- if (MpInterpPUTBACK(interp)) {
- /* PerlInterpScope handler */
- modperl_interp_unselect(interp);
- rcfg->interp = NULL;
- }
+ MP_TRACE_i(MP_FUNC, "unselecting: (0x%lx)->refcnt=%ld\n",
+ interp, interp->refcnt);
+ modperl_interp_unselect(interp);
#endif
/* flush output buffer after interpreter is putback */
Index: src/modules/perl/modperl_callback.c
===================================================================
--- src/modules/perl/modperl_callback.c (revision 578102)
+++ src/modules/perl/modperl_callback.c (working copy)
@@ -185,11 +185,10 @@
}
#ifdef USE_ITHREADS
- if (r && !c && modperl_interp_scope_connection(scfg)) {
- c = r->connection;
- }
if (r || c) {
interp = modperl_interp_select(r, c, s);
+ MP_TRACE_i(MP_FUNC, "just selected: (0x%lx)->refcnt=%ld\n",
+ interp, interp->refcnt);
aTHX = interp->perl;
}
else {
@@ -199,14 +198,6 @@
}
#endif
- /* XXX: would like to do this in modperl_hook_create_request()
- * but modperl_interp_select() is what figures out if
- * PerlInterpScope eq handler, in which case we do not register
- * a cleanup. modperl_hook_create_request() is also currently always
- * run even if modperl isn't handling any part of the request
- */
- modperl_config_req_cleanup_register(r, rcfg);
-
switch (type) {
case MP_HANDLER_TYPE_PER_SRV:
modperl_handler_make_args(aTHX_ &av_args,
@@ -357,8 +348,13 @@
SvREFCNT_dec((SV*)av_args);
- /* PerlInterpScope handler */
- MP_INTERP_PUTBACK(interp);
+#ifdef USE_ITHREADS
+ if (r || c) {
+ MP_TRACE_i(MP_FUNC, "unselecting: (0x%lx)->refcnt=%ld\n",
+ interp, interp->refcnt);
+ modperl_interp_unselect(interp);
+ }
+#endif
return status;
}
Index: src/modules/perl/modperl_interp.c
===================================================================
--- src/modules/perl/modperl_interp.c (revision 578102)
+++ src/modules/perl/modperl_interp.c (working copy)
@@ -61,7 +61,7 @@
memset(interp, '\0', sizeof(*interp));
interp->mip = mip;
- interp->refcnt = 0; /* for use by APR::Pool->cleanup_register */
+ interp->refcnt = 0;
if (perl) {
#ifdef MP_USE_GTOP
@@ -268,33 +268,43 @@
scfg->mip = mip;
}
+#ifdef MP_TRACE
+static apr_status_t modperl_interp_pool_cleanup(void *data)
+{
+ MP_TRACE_i(MP_FUNC, "unselecting: (0x%lx)->refcnt=%ld\n",
+ data, ((modperl_interp_t*)data)->refcnt);
+
+ return modperl_interp_unselect(data);
+}
+#endif
+
apr_status_t modperl_interp_unselect(void *data)
{
modperl_interp_t *interp = (modperl_interp_t *)data;
modperl_interp_pool_t *mip = interp->mip;
+ if (interp == mip->parent) return APR_SUCCESS;
+
+ ap_assert(interp && MpInterpIN_USE(interp));
+ MP_TRACE_i(MP_FUNC, "unselect(interp=0x%lx): refcnt=%d\n",
+ (unsigned long)interp, interp->refcnt);
if (interp->refcnt != 0) {
--interp->refcnt;
- MP_TRACE_i(MP_FUNC, "interp=0x%lx, refcnt=%d\n",
+ MP_TRACE_i(MP_FUNC, "interp=0x%lx, refcnt=%d -- interp still in use\n",
(unsigned long)interp, interp->refcnt);
return APR_SUCCESS;
}
- if (interp->request) {
- /* ithreads + a threaded mpm + PerlInterpScope handler */
- request_rec *r = interp->request;
- MP_dRCFG;
- modperl_config_request_cleanup(interp->perl, r);
- MpReqCLEANUP_REGISTERED_Off(rcfg);
- }
-
+ interp->ccfg->interp = NULL;
MpInterpIN_USE_Off(interp);
- MpInterpPUTBACK_Off(interp);
MP_THX_INTERP_SET(interp->perl, NULL);
modperl_tipool_putback_data(mip->tipool, data, interp->num_requests);
+ MP_TRACE_i(MP_FUNC, "interp=0x%lx freed, tipool(size=%ld, in_use=%ld)\n",
+ (unsigned long)interp, mip->tipool->size, mip->tipool->in_use);
+
return APR_SUCCESS;
}
@@ -321,13 +331,9 @@
}
void modperl_interp_pool_set(apr_pool_t *p,
- modperl_interp_t *interp,
- int cleanup)
+ modperl_interp_t *interp)
{
- /* same as get_interp but optional cleanup */
- (void)apr_pool_userdata_set((void *)interp, MP_INTERP_KEY,
- cleanup ? modperl_interp_unselect : NULL,
- p);
+ (void)apr_pool_userdata_set((void *)interp, MP_INTERP_KEY, NULL, p);
}
/*
@@ -342,46 +348,58 @@
MP_dSCFG(s);
modperl_interp_t *interp = NULL;
- if (scfg && (is_startup || !modperl_threaded_mpm())) {
- MP_TRACE_i(MP_FUNC, "using parent interpreter at %s\n",
- is_startup ? "startup" : "request time (non-threaded MPM)");
+ if (is_startup) {
+ if (scfg) {
+ MP_TRACE_i(MP_FUNC, "using parent interpreter at startup\n");
- if (!scfg->mip) {
- /* we get here if directive handlers are invoked
- * before server merge.
- */
- modperl_init_vhost(s, p, NULL);
- }
+ if (!scfg->mip) {
+ /* we get here if directive handlers are invoked
+ * before server merge.
+ */
+ modperl_init_vhost(s, p, NULL);
+ }
- interp = scfg->mip->parent;
+ interp = scfg->mip->parent;
+ }
+ else {
+ if (!(interp = modperl_interp_pool_get(p))) {
+ interp = modperl_interp_get(s);
+ modperl_interp_pool_set(p, interp);
+
+ MP_TRACE_i(MP_FUNC, "set interp 0x%lx in pconf pool 0x%lx\n",
+ (unsigned long)interp, (unsigned long)p);
+ }
+ else {
+ MP_TRACE_i(MP_FUNC, "found interp 0x%lx in pconf pool 0x%lx\n",
+ (unsigned long)interp, (unsigned long)p);
+ }
+ }
+
+ return interp;
}
+ else if (!modperl_threaded_mpm()) {
+ MP_TRACE_i(MP_FUNC, "using parent interpreter in non-threaded mode\n");
+ return scfg->mip->parent;
+ }
else {
- if (!(interp = modperl_interp_pool_get(p))) {
- interp = modperl_interp_get(s);
- modperl_interp_pool_set(p, interp, TRUE);
-
- MP_TRACE_i(MP_FUNC, "set interp in request time pool 0x%lx\n",
- (unsigned long)p);
- }
- else {
- MP_TRACE_i(MP_FUNC, "found interp in request time pool 0x%lx\n",
- (unsigned long)p);
- }
+ request_rec *r;
+ apr_pool_userdata_get((void **)&r, "MODPERL_R", p);
+ ap_assert(r);
+ MP_TRACE_i(MP_FUNC, "found userdata MODPERL_R in pool %#lx as %lx\n",
+ (unsigned long)r->pool, (unsigned long)r);
+ return modperl_interp_select(r, NULL, s);
}
-
- return interp;
}
modperl_interp_t *modperl_interp_select(request_rec *r, conn_rec *c,
server_rec *s)
{
MP_dSCFG(s);
- MP_dRCFG;
- modperl_config_dir_t *dcfg = modperl_config_dir_get(r);
+ MP_dDCFG;
+ modperl_config_con_t *ccfg;
const char *desc = NULL;
modperl_interp_t *interp = NULL;
apr_pool_t *p = NULL;
- int is_subrequest = (r && r->main) ? 1 : 0;
modperl_interp_scope_e scope;
if (!modperl_threaded_mpm()) {
@@ -390,22 +408,35 @@
(unsigned long)scfg->mip->parent,
s->server_hostname, s->port);
/* XXX: if no VirtualHosts w/ PerlOptions +Parent we can skip this */
- PERL_SET_CONTEXT(scfg->mip->parent->perl);
+ PERL_SET_CONTEXT(scfg->mip->parent->perl);
return scfg->mip->parent;
}
- if (rcfg && rcfg->interp) {
- /* if scope is per-handler and something selected an interpreter
- * before modperl_callback_run_handlers() and is still holding it,
- * e.g. modperl_response_handler_cgi(), that interpreter will
- * be here
- */
+ if(!c) c = r->connection;
+ ccfg = modperl_config_con_get(c);
+
+ if (ccfg && ccfg->interp) {
+ ccfg->interp->refcnt++;
+
MP_TRACE_i(MP_FUNC,
- "found interp 0x%lx in request config\n",
- (unsigned long)rcfg->interp);
- return rcfg->interp;
+ "found interp 0x%lx in con config, refcnt incremented to %d\n",
+ (unsigned long)ccfg->interp, ccfg->interp->refcnt);
+ return ccfg->interp;
}
+ interp = modperl_interp_get(s ? s : r->server);
+ ++interp->num_requests; /* should only get here once per request */
+ interp->refcnt = 0;
+
+ /* make sure ccfg is initialized */
+ modperl_config_con_init(c, ccfg);
+ ccfg->interp = interp;
+ interp->ccfg = ccfg;
+
+ MP_TRACE_i(MP_FUNC,
+ "pulled interp 0x%lx from mip, num_requests is %d\n",
+ (unsigned long)interp, interp->num_requests);
+
/*
* if a per-dir PerlInterpScope is specified, use it.
* else if r != NULL use per-server PerlInterpScope
@@ -419,90 +450,50 @@
MP_TRACE_i(MP_FUNC, "scope is per-%s\n",
modperl_interp_scope_desc(scope));
- /*
- * XXX: goto modperl_interp_get() if scope == handler ?
- */
+ if (scope != MP_INTERP_SCOPE_HANDLER) {
+ desc = NULL;
+ if (c && (scope == MP_INTERP_SCOPE_CONNECTION || !r)) {
+ p = c->pool;
+ desc = "connection";
+ }
+ else if (r) {
+ request_rec *main_r = r->main;
- if (c && (scope == MP_INTERP_SCOPE_CONNECTION)) {
- desc = "conn_rec pool";
- get_interp(c->pool);
+ if (main_r && (scope == MP_INTERP_SCOPE_REQUEST)) {
+ /* share 1 interpreter across sub-requests */
+ for(; main_r; main_r = main_r->main) {
+ p = main_r->pool;
+ }
+ desc = "main request";
+ }
+ else {
+ p = r->pool;
+ desc = scope == MP_INTERP_SCOPE_REQUEST
+ ? "main request"
+ : "sub request";
+ }
+ }
- if (interp) {
- MP_TRACE_i(MP_FUNC,
- "found interp 0x%lx in %s 0x%lx\n",
- (unsigned long)interp, desc, (unsigned long)c->pool);
- return interp;
- }
+ ap_assert(p);
- p = c->pool;
- }
- else if (r) {
- if (is_subrequest && (scope == MP_INTERP_SCOPE_REQUEST)) {
- /* share 1 interpreter across sub-requests */
- request_rec *main_r = r->main;
+#ifdef MP_TRACE
+ apr_pool_cleanup_register(p, (void *)interp,
+ modperl_interp_pool_cleanup,
+ modperl_interp_pool_cleanup);
+#else
+ apr_pool_cleanup_register(p, (void *)interp,
+ modperl_interp_unselect,
+ modperl_interp_unselect);
+#endif
- while (main_r && !interp) {
- p = main_r->pool;
- get_interp(p);
- MP_TRACE_i(MP_FUNC,
- "looking for interp in main request for %s...%s\n",
- main_r->uri, interp ? "found" : "not found");
- main_r = main_r->main;
- }
- }
- else {
- p = r->pool;
- get_interp(p);
- }
+ /* add a reference for the registered cleanup */
+ interp->refcnt++;
- desc = "request_rec pool";
-
- if (interp) {
- MP_TRACE_i(MP_FUNC,
- "found interp 0x%lx in %s 0x%lx (%s request for %s)\n",
- (unsigned long)interp, desc, (unsigned long)p,
- (is_subrequest ? "sub" : "main"), r->uri);
- return interp;
- }
-
- /* might have already been set by a ConnectionHandler */
- get_interp(r->connection->pool);
-
- if (interp) {
- desc = "r->connection pool";
- MP_TRACE_i(MP_FUNC,
- "found interp 0x%lx in %s 0x%lx\n",
- (unsigned long)interp, desc,
- (unsigned long)r->connection->pool);
- return interp;
- }
+ MP_TRACE_i(MP_FUNC,
+ "registered unselect cleanup for interp 0x%lx in %s\n",
+ (unsigned long)interp, desc);
}
- interp = modperl_interp_get(s ? s : r->server);
- ++interp->num_requests; /* should only get here once per request */
-
- if (scope == MP_INTERP_SCOPE_HANDLER) {
- /* caller is responsible for calling modperl_interp_unselect() */
- interp->request = r;
- MpReqCLEANUP_REGISTERED_On(rcfg);
- MpInterpPUTBACK_On(interp);
- }
- else {
- if (!p) {
- /* should never happen */
- MP_TRACE_i(MP_FUNC, "no pool\n");
- return NULL;
- }
-
- set_interp(p);
-
- MP_TRACE_i(MP_FUNC,
- "set interp 0x%lx in %s 0x%lx (%s request for %s)\n",
- (unsigned long)interp, desc, (unsigned long)p,
- (r ? (is_subrequest ? "sub" : "main") : "conn"),
- (r ? r->uri : c->remote_ip));
- }
-
/* set context (THX) for this thread */
PERL_SET_CONTEXT(interp->perl);
@@ -590,3 +581,9 @@
}
#endif /* USE_ITHREADS */
+
+/*
+ * Local Variables:
+ * c-basic-offset: 4
+ * End:
+ */
Index: src/modules/perl/modperl_config.c
===================================================================
--- src/modules/perl/modperl_config.c (revision 578102)
+++ src/modules/perl/modperl_config.c (working copy)
@@ -379,9 +379,26 @@
apr_status_t modperl_config_req_cleanup(void *data)
{
request_rec *r = (request_rec *)data;
- MP_dTHX;
+ apr_status_t rc;
- return modperl_config_request_cleanup(aTHX_ r);
+#ifdef USE_ITHREADS
+ pTHX;
+ modperl_interp_t *interp = modperl_interp_select(r, NULL, r->server);
+
+ MP_TRACE_i(MP_FUNC, "just selected: (0x%lx)->refcnt=%ld\n",
+ interp, interp->refcnt);
+ aTHX = interp->perl;
+#endif
+
+ rc = modperl_config_request_cleanup(aTHX_ r);
+
+#ifdef USE_ITHREADS
+ MP_TRACE_i(MP_FUNC, "unselecting: (0x%lx)->refcnt=%ld\n",
+ interp, interp->refcnt);
+ modperl_interp_unselect(interp);
+#endif
+
+ return rc;
}
void *modperl_get_perl_module_config(ap_conf_vector_t *cv)
Index: src/modules/perl/modperl_interp.h
===================================================================
--- src/modules/perl/modperl_interp.h (revision 578102)
+++ src/modules/perl/modperl_interp.h (working copy)
@@ -77,8 +77,7 @@
modperl_interp_t *modperl_interp_pool_get(apr_pool_t *p);
void modperl_interp_pool_set(apr_pool_t *p,
- modperl_interp_t *interp,
- int cleanup);
+ modperl_interp_t *interp);
modperl_interp_t *modperl_interp_pool_select(apr_pool_t *p,
server_rec *s);
@@ -93,7 +92,7 @@
aTHX = interp->perl
#define MP_INTERP_PUTBACK(interp) \
- if (interp && MpInterpPUTBACK(interp)) { \
+ if (interp) { \
modperl_interp_unselect(interp); \
}
Index: src/modules/perl/modperl_types.h
===================================================================
--- src/modules/perl/modperl_types.h (revision 578102)
+++ src/modules/perl/modperl_types.h (working copy)
@@ -52,13 +52,14 @@
typedef struct modperl_interp_t modperl_interp_t;
typedef struct modperl_interp_pool_t modperl_interp_pool_t;
typedef struct modperl_tipool_t modperl_tipool_t;
+typedef struct modperl_config_con_t modperl_config_con_t;
struct modperl_interp_t {
modperl_interp_pool_t *mip;
PerlInterpreter *perl;
int num_requests;
U8 flags;
- request_rec *request;
+ modperl_config_con_t *ccfg;
int refcnt;
#ifdef MP_TRACE
unsigned long tid;
@@ -258,9 +259,12 @@
#endif
} modperl_config_req_t;
-typedef struct {
+struct modperl_config_con_t {
HV *pnotes;
-} modperl_config_con_t;
+#ifdef USE_ITHREADS
+ modperl_interp_t *interp;
+#endif
+};
typedef struct {
apr_pool_t *pool;
Index: src/modules/perl/modperl_cmd.c
===================================================================
--- src/modules/perl/modperl_cmd.c (revision 578102)
+++ src/modules/perl/modperl_cmd.c (working copy)
@@ -558,6 +558,9 @@
arg, NULL);
}
+ MP_TRACE_i(MP_FUNC, "using interp %lx to execute perl section:\n%s\n",
+ scfg->mip->parent, arg);
+
{
SV *server = MP_PERLSECTIONS_SERVER_SV;
SV *code = newSVpv(arg, 0);
Index: xs/APR/Pool/APR__Pool.h
===================================================================
--- xs/APR/Pool/APR__Pool.h (revision 578102)
+++ xs/APR/Pool/APR__Pool.h (working copy)
@@ -75,6 +75,8 @@
* there are no more references, in which case \
* the interpreter will be putback into the mip \
*/ \
+ MP_TRACE_i(MP_FUNC, "DO: calling interp_unselect(0x%lx)\n", \
+ acct->interp); \
(void)modperl_opt_interp_unselect(acct->interp); \
} \
} STMT_END
@@ -97,6 +99,8 @@
*/ \
if ((acct->interp = MP_THX_INTERP_GET(aTHX))) { \
acct->interp->refcnt++; \
+ MP_TRACE_i(MP_FUNC, "TO: (0x%lx)->refcnt incremented to %ld\n", \
+ acct->interp, acct->interp->refcnt); \
} \
} STMT_END
@@ -303,6 +307,7 @@
* there are no more references, in which case
* the interpreter will be putback into the mip
*/
+ MP_TRACE_i(MP_FUNC, "calling interp_unselect(0x%lx)\n", cdata->interp);
(void)modperl_opt_interp_unselect(cdata->interp);
}
#endif
@@ -337,6 +342,8 @@
*/
if ((data->interp = MP_THX_INTERP_GET(data->perl))) {
data->interp->refcnt++;
+ MP_TRACE_i(MP_FUNC, "(0x%lx)->refcnt incremented to %ld\n",
+ data->interp, data->interp->refcnt);
}
#endif
Index: t/response/TestDirective/perlcleanuphandler.pm
===================================================================
--- t/response/TestDirective/perlcleanuphandler.pm (revision 0)
+++ t/response/TestDirective/perlcleanuphandler.pm (revision 0)
@@ -0,0 +1,74 @@
+package TestDirective::perlcleanuphandler;
+
+use strict;
+use warnings FATAL => 'all';
+
+use Apache2::RequestRec;
+use Apache2::RequestIO;
+use Apache2::RequestUtil;
+use Apache2::Connection;
+use Apache2::ConnectionUtil;
+use Apache2::Const -compile => 'OK', 'DECLINED';
+
+# This test is to show an error that occurs if in the whole request cycle
+# only a PerlCleanupHandler is defined. In this case it is not called.
+# To check that the get() handler is called first with the ?incr parameter.
+# This returns "UNDEF" to the browser and sets the counter to "1".
+# Next get() is called again without args to check the counter without
+# increment. Then we fetch "/?incr". Here no other Perl*Handler save the
+# PerlCleanupHandler is involved. So the next get() must return "2" but it
+# shows "1".
+
+sub cleanup {
+ my $r=shift;
+ warn "cleanup: ".$r->uri.'?'.$r->args;
+ $r->connection->pnotes->{counter}++ if( $r->args eq 'incr' );
+ return Apache2::Const::OK;
+}
+
+sub get {
+ my $r=shift;
+ $r->content_type('text/plain');
+ $r->print($r->connection->pnotes->{counter} || "UNDEF");
+ return Apache2::Const::OK;
+}
+
+1;
+
+__END__
+# APACHE_TEST_CONFIG_ORDER 942
+
+<VirtualHost TestDirective::perlcleanuphandler>
+
+ <IfDefine PERL_USEITHREADS>
+ # a new interpreter pool
+ PerlOptions +Parent
+ PerlInterpStart 1
+ PerlInterpMax 1
+ PerlInterpMinSpare 0
+ PerlInterpMaxSpare 1
+ PerlInterpScope connection
+ </IfDefine>
+
+ KeepAlive On
+ KeepAliveTimeout 300
+ MaxKeepAliveRequests 100
+
+ # use test system's @INC
+ PerlSwitches [EMAIL PROTECTED]@
+ PerlRequire "conf/modperl_inc.pl"
+ PerlModule TestDirective::perlcleanuphandler
+
+ <Location /get>
+ SetHandler modperl
+ PerlResponseHandler TestDirective::perlcleanuphandler::get
+ </Location>
+
+ PerlCleanupHandler TestDirective::perlcleanuphandler::cleanup
+
+</VirtualHost>
+
+# Local Variables: #
+# mode: cperl #
+# cperl-indent-level: 4 #
+# End: #
Index: t/directive/perlcleanuphandler.t
===================================================================
--- t/directive/perlcleanuphandler.t (revision 0)
+++ t/directive/perlcleanuphandler.t (revision 0)
@@ -0,0 +1,24 @@
+use strict;
+use warnings FATAL => 'all';
+
+use Apache::Test;
+use Apache::TestUtil;
+use Apache::TestRequest 'GET_BODY';
+
+plan tests => 3;
+
+my $module = 'TestDirective::perlcleanuphandler';
+
+Apache::TestRequest::user_agent(reset => 1, keep_alive=>10);
+sub u {Apache::TestRequest::module2url($module, {path=>$_[0]})}
+
+t_debug("connecting to ".u(''));
+ok t_cmp GET_BODY(u('/get?incr')), 'UNDEF', 'before increment';
+ok t_cmp GET_BODY(u('/get')), '1', 'incremented';
+(undef)=GET_BODY(u('/index.html?incr'));
+ok t_cmp GET_BODY(u('/get')), '2', 'incremented again';
+
+# Local Variables: #
+# mode: cperl #
+# cperl-indent-level: 4 #
+# End: #
Index: t/response/TestDirective/perlcleanuphandler.pm
===================================================================
--- t/response/TestDirective/perlcleanuphandler.pm (revision 0)
+++ t/response/TestDirective/perlcleanuphandler.pm (revision 0)
@@ -0,0 +1,74 @@
+package TestDirective::perlcleanuphandler;
+
+use strict;
+use warnings FATAL => 'all';
+
+use Apache2::RequestRec;
+use Apache2::RequestIO;
+use Apache2::RequestUtil;
+use Apache2::Connection;
+use Apache2::ConnectionUtil;
+use Apache2::Const -compile => 'OK', 'DECLINED';
+
+# This test is to show an error that occurs if in the whole request cycle
+# only a PerlCleanupHandler is defined. In this case it is not called.
+# To check that the get() handler is called first with the ?incr parameter.
+# This returns "UNDEF" to the browser and sets the counter to "1".
+# Next get() is called again without args to check the counter without
+# increment. Then we fetch "/?incr". Here no other Perl*Handler save the
+# PerlCleanupHandler is involved. So the next get() must return "2" but it
+# shows "1".
+
+sub cleanup {
+ my $r=shift;
+ warn "cleanup: ".$r->uri.'?'.$r->args;
+ $r->connection->pnotes->{counter}++ if( $r->args eq 'incr' );
+ return Apache2::Const::OK;
+}
+
+sub get {
+ my $r=shift;
+ $r->content_type('text/plain');
+ $r->print($r->connection->pnotes->{counter} || "UNDEF");
+ return Apache2::Const::OK;
+}
+
+1;
+
+__END__
+# APACHE_TEST_CONFIG_ORDER 942
+
+<VirtualHost TestDirective::perlcleanuphandler>
+
+ <IfDefine PERL_USEITHREADS>
+ # a new interpreter pool
+ PerlOptions +Parent
+ PerlInterpStart 1
+ PerlInterpMax 1
+ PerlInterpMinSpare 0
+ PerlInterpMaxSpare 1
+ PerlInterpScope connection
+ </IfDefine>
+
+ KeepAlive On
+ KeepAliveTimeout 300
+ MaxKeepAliveRequests 100
+
+ # use test system's @INC
+ PerlSwitches [EMAIL PROTECTED]@
+ PerlRequire "conf/modperl_inc.pl"
+ PerlModule TestDirective::perlcleanuphandler
+
+ <Location /get>
+ SetHandler modperl
+ PerlResponseHandler TestDirective::perlcleanuphandler::get
+ </Location>
+
+ PerlCleanupHandler TestDirective::perlcleanuphandler::cleanup
+
+</VirtualHost>
+
+# Local Variables: #
+# mode: cperl #
+# cperl-indent-level: 4 #
+# End: #
Index: t/directive/perlcleanuphandler.t
===================================================================
--- t/directive/perlcleanuphandler.t (revision 0)
+++ t/directive/perlcleanuphandler.t (revision 0)
@@ -0,0 +1,24 @@
+use strict;
+use warnings FATAL => 'all';
+
+use Apache::Test;
+use Apache::TestUtil;
+use Apache::TestRequest 'GET_BODY';
+
+plan tests => 3;
+
+my $module = 'TestDirective::perlcleanuphandler';
+
+Apache::TestRequest::user_agent(reset => 1, keep_alive=>10);
+sub u {Apache::TestRequest::module2url($module, {path=>$_[0]})}
+
+t_debug("connecting to ".u(''));
+ok t_cmp GET_BODY(u('/get?incr')), 'UNDEF', 'before increment';
+ok t_cmp GET_BODY(u('/get')), '1', 'incremented';
+(undef)=GET_BODY(u('/index.html?incr'));
+ok t_cmp GET_BODY(u('/get')), '2', 'incremented again';
+
+# Local Variables: #
+# mode: cperl #
+# cperl-indent-level: 4 #
+# End: #
pgplmivALcwXh.pgp
Description: PGP signature
