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 jo...@apache.org on 2004/10/04 02:05:24 UTC
cvs commit: modperl-2.0/xs/APR/Pool APR__Pool.h
joes 2004/10/03 17:05:24
Modified: xs/APR/Pool APR__Pool.h
Added: t/apr pool_lifetime.t
t/response/TestAPR pool_lifetime.pm
Log:
Mark pools created by APR::Pool::new by adding sv_magic instead of
apr_pool_userdata_set. This allows such pools to be destroyed by
apache before the SV object is DESTROYed by perl.
http://marc.theaimsgroup.com/?l=apache-modperl-dev&w=2&r=1&s=ap_save_brigage&q=t
Reviewed by: gozer, stas
Revision Changes Path
1.1 modperl-2.0/t/apr/pool_lifetime.t
Index: pool_lifetime.t
===================================================================
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
}
}
1.1 modperl-2.0/t/response/TestAPR/pool_lifetime.pm
Index: pool_lifetime.pm
===================================================================
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
1.18 +103 -119 modperl-2.0/xs/APR/Pool/APR__Pool.h
Index: APR__Pool.h
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/APR/Pool/APR__Pool.h,v
retrieving revision 1.17
retrieving revision 1.18
diff -u -r1.17 -r1.18
--- APR__Pool.h 14 Jul 2004 23:15:01 -0000 1.17
+++ APR__Pool.h 4 Oct 2004 00:05:24 -0000 1.18
@@ -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) STMT_START { \
+ 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); \
+ } \
+} STMT_END
+
+#define MP_APR_POOL_SV_TAKES_OWNERSHIP(acct_sv, pool) STMT_START { \
+ mpxs_pool_account_t *acct = apr_palloc(pool, sizeof *acct); \
+ acct->sv = acct_sv; \
+ acct->perl = aTHX; \
+ SvIVX(acct_sv) = PTR2IV(pool); \
+ \
+ sv_magic(acct_sv, Nullsv, PERL_MAGIC_ext, \
+ MP_APR_POOL_NEW, sizeof(MP_APR_POOL_NEW)); \
+ \
+ apr_pool_cleanup_register(pool, (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++; \
+ } \
+} STMT_END
+
+#else /* !USE_ITHREADS */
+
+#define MP_APR_POOL_SV_DROPS_OWNERSHIP(acct) STMT_START { \
+ mg_free(acct->sv); \
+ SvIVX(acct->sv) = 0; \
+} STMT_END
+
+#define MP_APR_POOL_SV_TAKES_OWNERSHIP(acct_sv, pool) STMT_START { \
+ mpxs_pool_account_t *acct = apr_palloc(pool, sizeof *acct); \
+ acct->sv = acct_sv; \
+ SvIVX(acct_sv) = PTR2IV(pool); \
+ \
+ sv_magic(acct_sv, Nullsv, PERL_MAGIC_ext, \
+ MP_APR_POOL_NEW, sizeof(MP_APR_POOL_NEW)); \
+ \
+ apr_pool_cleanup_register(pool, (void *)acct, \
+ mpxs_apr_pool_cleanup, \
+ apr_pool_cleanup_null); \
+} STMT_END
+
+#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;
}
@@ -100,25 +153,6 @@
(unsigned long)child_pool, (unsigned long)parent_pool);
}
- /* Each newly created pool must be destroyed only once. Calling
- * apr_pool_destroy will destroy the pool and its children pools,
- * however a perl object for a sub-pool will still keep a pointer
- * to the pool which was already destroyed. When this object is
- * DESTROYed, apr_pool_destroy will be called again. In the best
- * case it'll try to destroy a non-existing pool, but in the worst
- * case it'll destroy a different valid pool which has been given
- * the same memory allocation wrecking havoc. Therefore we must
- * ensure that when sub-pools are destroyed via the parent pool,
- * their cleanup callbacks will destroy the guts of their perl
- * objects, so when those perl objects, pointing to memory
- * previously allocated by destroyed sub-pools or re-used already
- * by new pools, will get their time to DESTROY, they won't make a
- * 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 +173,30 @@
#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);
+ /* Each newly created pool must be destroyed only once. Calling
+ * apr_pool_destroy will destroy the pool and its children pools,
+ * however a perl object for a sub-pool will still keep a pointer
+ * to the pool which was already destroyed. When this object is
+ * DESTROYed, apr_pool_destroy will be called again. In the best
+ * case it'll try to destroy a non-existing pool, but in the worst
+ * case it'll destroy a different valid pool which has been given
+ * the same memory allocation wrecking havoc. Therefore we must
+ * ensure that when sub-pools are destroyed via the parent pool,
+ * their cleanup callbacks will destroy the guts of their perl
+ * objects, so when those perl objects, pointing to memory
+ * previously allocated by destroyed sub-pools or re-used already
+ * by new pools, will get their time to DESTROY, they won't make a
+ * mess, trying to destroy an already destroyed pool or even worse
+ * a pool allocate in the place of the old one.
+ */
- MP_POOL_TRACE(MP_FUNC, "sub-pool p: 0x%lx, sv: 0x%lx, rv: 0x%lx",
- (unsigned long)child_pool, data->sv, rv);
+ MP_APR_POOL_SV_TAKES_OWNERSHIP(sv, child_pool);
- apr_pool_userdata_set(data, MP_APR_POOL_NEW, NULL, child_pool);
+ MP_POOL_TRACE(MP_FUNC, "sub-pool p: 0x%lx, sv: 0x%lx, rv: 0x%lx",
+ (unsigned long)child_pool, sv, rv);
return rv;
}
@@ -158,10 +205,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 +217,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 +244,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 +330,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 +345,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);
}
}