Stas Bekman <[EMAIL PROTECTED]> writes:
[...]
> Looking at the most recent post on the topic from Sep 30th, you were
> still discussing some nuances, like MP_APR_POOL_SV_DROPS_OWNERSHIP,
> and I was expecting to see the final patch, before reviewing it.
Err, ok- personally I thought the discussion ended, and it
was now a matter of incorporating the suggested tweaks
and committing it. I want to commit the bucket changes
today also, and then move on to fixing the t/directive/cmdparams.t
segfaults on amd64 (also reported+patched earlier this week).
Knocking the pool patch out first seems like a good idea.
> Mind to post the latest version (sorry if you did already and I've
> missed it).
Sure- with Philippe's t/apr/pool_lifetime.t test included.
Index: xs/APR/Pool/APR__Pool.h
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/APR/Pool/APR__Pool.h,v
retrieving revision 1.17
diff -u -r1.17 APR__Pool.h
--- xs/APR/Pool/APR__Pool.h 14 Jul 2004 23:15:01 -0000 1.17
+++ xs/APR/Pool/APR__Pool.h 3 Oct 2004 16:35:43 -0000
@@ -17,6 +17,10 @@
typedef struct {
SV *sv;
+#ifdef USE_ITHREADS
+ PerlInterpreter *perl;
+ modperl_interp_t *interp;
+#endif
} mpxs_pool_account_t;
/* XXX: this implementation has a problem with perl ithreads. if a
@@ -33,6 +37,73 @@
* that?) may be we can skip those?
*/
+#ifndef MP_SOURCE_SCAN
+#include "apr_optional.h"
+static
+APR_OPTIONAL_FN_TYPE(modperl_interp_unselect) *modperl_opt_interp_unselect;
+#endif
+
+#define MP_APR_POOL_SV_HAS_OWNERSHIP(sv) (mg_find(sv, PERL_MAGIC_ext) != NULL)
+
+#ifdef USE_ITHREADS
+
+#define MP_APR_POOL_SV_DROPS_OWNERSHIP(acct) do { \
+ dTHXa(acct->perl); \
+ mg_free(acct->sv); \
+ SvIVX(acct->sv) = 0; \
+ if (modperl_opt_interp_unselect && acct->interp) { \
+ /* this will decrement the interp refcnt until \
+ * there are no more references, in which case \
+ * the interpreter will be putback into the mip \
+ */ \
+ (void)modperl_opt_interp_unselect(acct->interp); \
+ } \
+} while (0)
+
+#define MP_APR_POOL_SV_TAKES_OWNERSHIP(SV, P) do { \
+ mpxs_pool_account_t *acct = apr_palloc(P, sizeof *acct); \
+ acct->sv = SV; \
+ acct->perl = aTHX; \
+ SvIVX(SV) = PTR2IV(P); \
+ \
+ sv_magic(SV, Nullsv, PERL_MAGIC_ext, \
+ MP_APR_POOL_NEW, sizeof(MP_APR_POOL_NEW)); \
+ \
+ apr_pool_cleanup_register(P, (void *)acct, \
+ mpxs_apr_pool_cleanup, \
+ apr_pool_cleanup_null); \
+ \
+ /* make sure interpreter is not putback into the mip \
+ * until this cleanup has run. \
+ */ \
+ if ((acct->interp = MP_THX_INTERP_GET(aTHX))) { \
+ acct->interp->refcnt++; \
+ } \
+} while (0)
+
+#else /* !USE_ITHREADS */
+
+#define MP_APR_POOL_SV_DROPS_OWNERSHIP(acct) do { \
+ mg_free(acct->sv); \
+ SvIVX(acct->sv) = 0; \
+} while (0)
+
+#define MP_APR_POOL_SV_TAKES_OWNERSHIP(SV, P) do { \
+ mpxs_pool_account_t *acct = apr_palloc(P, sizeof *acct); \
+ acct->sv = SV; \
+ SvIVX(SV) = PTR2IV(P); \
+ \
+ sv_magic(SV, Nullsv, PERL_MAGIC_ext, \
+ MP_APR_POOL_NEW, sizeof(MP_APR_POOL_NEW)); \
+ \
+ apr_pool_cleanup_register(P, (void *)acct, \
+ mpxs_apr_pool_cleanup, \
+ apr_pool_cleanup_null); \
+} while (0)
+
+#endif /* USE_ITHREADS */
+
+
/* XXX: should we make it a new global tracing category
* MOD_PERL_TRACE=p for tracing pool management? */
#define MP_POOL_TRACE_DO 0
@@ -50,26 +121,8 @@
static MP_INLINE apr_status_t
mpxs_apr_pool_cleanup(void *cleanup_data)
{
- mpxs_pool_account_t *data;
- apr_pool_userdata_get((void **)&data, MP_APR_POOL_NEW,
- (apr_pool_t *)cleanup_data);
- if (!(data && data->sv)) {
- /* if there is no data, there is nothing to unset */
- MP_POOL_TRACE(MP_FUNC, "this pool seems to be destroyed already");
- }
- else {
- MP_POOL_TRACE(MP_FUNC,
- "pool 0x%lx contains a valid sv 0x%lx, invalidating it",
- (unsigned long)data->sv, (unsigned long)cleanup_data);
-
- /* invalidate all Perl objects referencing this sv */
- SvIVX(data->sv) = 0;
-
- /* invalidate the reference stored in the pool */
- data->sv = NULL;
- /* data->sv will go away by itself when all objects will go away */
- }
-
+ mpxs_pool_account_t *acct = cleanup_data;
+ MP_APR_POOL_SV_DROPS_OWNERSHIP(acct);
return APR_SUCCESS;
}
@@ -116,9 +169,6 @@
* mess, trying to destroy an already destroyed pool or even worse
* a pool allocate in the place of the old one.
*/
- apr_pool_cleanup_register(child_pool, (void *)child_pool,
- mpxs_apr_pool_cleanup,
- apr_pool_cleanup_null);
#if APR_POOL_DEBUG
/* child <-> parent <-> ... <-> top ancestry traversal */
{
@@ -139,17 +189,13 @@
#endif
{
- mpxs_pool_account_t *data =
- (mpxs_pool_account_t *)apr_pcalloc(child_pool, sizeof(*data));
-
SV *rv = sv_setref_pv(NEWSV(0, 0), "APR::Pool", (void*)child_pool);
+ SV *sv = SvRV(rv);
- data->sv = SvRV(rv);
+ MP_APR_POOL_SV_TAKES_OWNERSHIP(sv, child_pool);
MP_POOL_TRACE(MP_FUNC, "sub-pool p: 0x%lx, sv: 0x%lx, rv: 0x%lx",
- (unsigned long)child_pool, data->sv, rv);
-
- apr_pool_userdata_set(data, MP_APR_POOL_NEW, NULL, child_pool);
+ (unsigned long)child_pool, sv, rv);
return rv;
}
@@ -158,10 +204,9 @@
static MP_INLINE void mpxs_APR__Pool_clear(pTHX_ SV *obj)
{
apr_pool_t *p = mp_xs_sv2_APR__Pool(obj);
- mpxs_pool_account_t *data;
+ SV *sv = SvRV(obj);
- apr_pool_userdata_get((void **)&data, MP_APR_POOL_NEW, p);
- if (!(data && data->sv)) {
+ if (!MP_APR_POOL_SV_HAS_OWNERSHIP(sv)) {
MP_POOL_TRACE(MP_FUNC, "parent pool (0x%lx) is a core pool",
(unsigned long)p);
apr_pool_clear(p);
@@ -171,20 +216,15 @@
MP_POOL_TRACE(MP_FUNC,
"parent pool (0x%lx) is a custom pool, sv 0x%lx",
(unsigned long)p,
- (unsigned long)data->sv);
+ (unsigned long)sv);
apr_pool_clear(p);
- /* apr_pool_clear removes all the user data, so we need to restore
+ /* apr_pool_clear runs & removes the cleanup, so we need to restore
* it. Since clear triggers mpxs_apr_pool_cleanup call, our
* object's guts get nuked too, so we need to restore them too */
- /* this is sv_setref_pv, but for an existing object */
- sv_setiv(newSVrv(obj, "APR::Pool"), PTR2IV((void*)p));
- data->sv = SvRV(obj);
-
- /* reinstall the user data */
- apr_pool_userdata_set(data, MP_APR_POOL_NEW, NULL, p);
+ MP_APR_POOL_SV_TAKES_OWNERSHIP(sv, p);
}
@@ -203,11 +243,6 @@
* @param data internal storage
*/
-#ifndef MP_SOURCE_SCAN
-#include "apr_optional.h"
-static
-APR_OPTIONAL_FN_TYPE(modperl_interp_unselect) *modperl_opt_interp_unselect;
-#endif
static apr_status_t mpxs_cleanup_run(void *data)
{
@@ -294,35 +329,12 @@
apr_pool_t *parent_pool = apr_pool_parent_get(child_pool);
if (parent_pool) {
- /* ideally this should be done by mp_xs_APR__Pool_2obj. Though
- * since most of the time we don't use custom pools, we don't
- * want the overhead of reading and writing pool's userdata in
- * the general case. therefore we do it here and in
- * mpxs_apr_pool_create. Though if there are any other
- * functions, that return perl objects whose guts include a
- * reference to a custom pool, they must do the ref-counting
- * as well.
- */
- mpxs_pool_account_t *data;
- apr_pool_userdata_get((void **)&data, MP_APR_POOL_NEW, parent_pool);
- if (data && data->sv) {
- MP_POOL_TRACE(MP_FUNC,
- "parent pool (0x%lx) is a custom pool, sv 0x%lx",
- (unsigned long)parent_pool,
- (unsigned long)data->sv);
-
- return newRV_inc(data->sv);
- }
- else {
- MP_POOL_TRACE(MP_FUNC, "parent pool (0x%lx) is a core pool",
- (unsigned long)parent_pool);
- return SvREFCNT_inc(mp_xs_APR__Pool_2obj(parent_pool));
- }
+ return SvREFCNT_inc(mp_xs_APR__Pool_2obj(parent_pool));
}
else {
MP_POOL_TRACE(MP_FUNC, "pool (0x%lx) has no parents",
(unsigned long)child_pool);
- return SvREFCNT_inc(mp_xs_APR__Pool_2obj(parent_pool));
+ return SvREFCNT_inc(mp_xs_APR__Pool_2obj(parent_pool));
}
}
@@ -332,40 +344,11 @@
*/
static MP_INLINE void mpxs_apr_pool_DESTROY(pTHX_ SV *obj)
{
- apr_pool_t *p;
SV *sv = SvRV(obj);
- /* MP_POOL_TRACE(MP_FUNC, "DESTROY 0x%lx-0x%lx", */
- /* (unsigned long)obj,(unsigned long)sv); */
- /* do_sv_dump(0, Perl_debug_log, obj, 0, 4, FALSE, 0); */
-
- p = mpxs_sv_object_deref(obj, apr_pool_t);
- if (!p) {
- /* non-custom pool */
- MP_POOL_TRACE(MP_FUNC, "skip apr_pool_destroy: not a custom pool");
- return;
- }
-
- if (sv && SvOK(sv)) {
- mpxs_pool_account_t *data;
-
- apr_pool_userdata_get((void **)&data, MP_APR_POOL_NEW, p);
- if (!(data && data->sv)) {
- MP_POOL_TRACE(MP_FUNC, "skip apr_pool_destroy: no sv found");
- return;
- }
-
- if (SvREFCNT(sv) == 1) {
- MP_POOL_TRACE(MP_FUNC, "call apr_pool_destroy: last reference");
- apr_pool_destroy(p);
- }
- else {
- /* when the pool object dies, sv's ref count decrements
- * itself automatically */
- MP_POOL_TRACE(MP_FUNC,
- "skip apr_pool_destroy: refcount > 1 (%d)",
- SvREFCNT(sv));
- }
+ if (MP_APR_POOL_SV_HAS_OWNERSHIP(sv)) {
+ apr_pool_t *p = mpxs_sv_object_deref(obj, apr_pool_t);
+ apr_pool_destroy(p);
}
}
Index: t/response/TestAPR/pool_lifetime.pm
===================================================================
RCS file: t/response/TestAPR/pool_lifetime.pm
diff -N t/response/TestAPR/pool_lifetime.pm
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ t/response/TestAPR/pool_lifetime.pm 3 Oct 2004 16:35:42 -0000
@@ -0,0 +1,28 @@
+package TestAPR::pool_lifetime;
+
+use strict;
+use warnings FATAL => 'all';
+
+use Apache::Test;
+use Apache::TestUtil;
+use Apache::TestTrace;
+
+use Apache::RequestRec ();
+use APR::Pool ();
+
+use Apache::Const -compile => 'OK';
+
+my $pool;
+sub handler {
+ my $r = shift;
+
+ $r->print("Pong");
+ $pool = $r->pool;
+
+ Apache::OK;
+}
+
+1;
+__END__
+
+PerlFixupHandler Apache::TestHandler::same_interp_fixup
Index: t/apr/pool_lifetime.t
===================================================================
RCS file: t/apr/pool_lifetime.t
diff -N t/apr/pool_lifetime.t
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ t/apr/pool_lifetime.t 3 Oct 2004 16:35:42 -0000
@@ -0,0 +1,60 @@
+use strict;
+use warnings FATAL => 'all';
+
+use Apache::Test;
+use Apache::TestUtil;
+use Apache::TestRequest;
+use File::Spec::Functions qw(catfile);
+
+plan tests => 2;
+
+my $module = 'TestAPR::pool_lifetime';
+my $location = '/' . Apache::TestRequest::module2path($module);
+
+t_debug "getting the same interp ID for $location";
+my $same_interp = Apache::TestRequest::same_interp_tie($location);
+
+my $skip = $same_interp ? 0 : 1;
+
+for (1..2) {
+ my $expected = "Pong";
+ my $received = get_body($same_interp, \&GET, $location);
+ $skip++ unless defined $received;
+ skip_not_same_interp(
+ $skip,
+ $expected,
+ $received,
+ "Pong"
+ );
+}
+
+# if we fail to find the same interpreter, return undef (this is not
+# an error)
+sub get_body {
+ my $res = eval {
+ Apache::TestRequest::same_interp_do(@_);
+ };
+ return undef if $@ =~ /unable to find interp/;
+ return $res->content if $res;
+ die $@ if $@;
+}
+
+# make the tests resistant to a failure of finding the same perl
+# interpreter, which happens randomly and not an error.
+# the first argument is used to decide whether to skip the sub-test,
+# the rest of the arguments are passed to 'ok t_cmp';
+sub skip_not_same_interp {
+ my $skip_cond = shift;
+ if ($skip_cond) {
+ skip "Skip couldn't find the same interpreter", 0;
+ }
+ else {
+ my($package, $filename, $line) = caller;
+ # trick ok() into reporting the caller filename/line when a
+ # sub-test fails in sok()
+ return eval <<EOE;
+#line $line $filename
+ ok &t_cmp;
+EOE
+ }
+}
--
Joe Schaefer
---------------------------------------------------------------------
To unsubscribe, e-mail: [EMAIL PROTECTED]
For additional commands, e-mail: [EMAIL PROTECTED]
