Index: t/response/TestAPR/pool.pm =================================================================== RCS file: /home/cvs/modperl-2.0/t/response/TestAPR/pool.pm,v retrieving revision 1.5 diff -u -r1.5 pool.pm --- t/response/TestAPR/pool.pm 9 Sep 2003 17:22:39 -0000 1.5 +++ t/response/TestAPR/pool.pm 26 Sep 2003 00:31:12 -0000 @@ -1,9 +1,11 @@ package TestAPR::pool;
use strict; -use warnings FATAL => 'all'; +use warnings;# FATAL => 'all';
use Apache::Test; +use Apache::TestUtil; +use Apache::TestTrace;
use Apache::RequestRec (); use APR::Pool (); @@ -11,85 +13,214 @@
use Apache::Const -compile => 'OK';
-sub add_cleanup {
- my $arg = shift;
- $arg->[0]->notes->add(cleanup => $arg->[1]);
- 1;
-}
-
-sub set_cleanup {
- my $arg = shift;
- $arg->[0]->notes->set(cleanup => $arg->[1]);
- 1;
-}
-
sub handler {
my $r = shift;- plan $r, tests => 13; + plan $r, tests => 38;
- my $p = APR::Pool->new; + ### native pools ###
- ok $p->isa('APR::Pool');
+ # explicit and implicit DESTROY shouldn't destroy native pools
+ {
+ my $p = $r->pool;- my $subp = $p->new; + ok t_cmp(5, ancestry_count($p), "\$r->pool has 5 ancestors");
- ok $subp->isa('APR::Pool');
+ $p->cleanup_register(\&set_cleanup, [$r, 'native DESTROY']);-#only available with -DAPR_POOL_DEBUG -# my $num_bytes = $p->num_bytes; -# ok $num_bytes; + $p->DESTROY;
- $p->cleanup_register(\&add_cleanup, [$r, 'parent']);
- $subp->cleanup_register(\&set_cleanup, [$r, 'child']);
+ my @notes = $r->notes->get('cleanup');- # should destroy the subpool too - $p->destroy; + ok t_cmp(0, scalar(@notes), "should be 0 notes");
- my @notes = $r->notes->get('cleanup');
- ok $notes[0] eq 'child';
- ok $notes[1] eq 'parent';
- ok @notes == 2;
+ $r->notes->clear;
+ }
+
+ # implicit DESTROY shouldn't destroy native pools
+ {
+ {
+ my $p = $r->pool;- # explicity DESTROY the objects - my $p2 = APR::Pool->new; - $p2->cleanup_register(\&set_cleanup, [$r, 'new DESTROY']); - $p2->DESTROY; + ok t_cmp(5, ancestry_count($p), "\$r->pool has 5 ancestors");
- @notes = $r->notes->get('cleanup');
- ok $notes[0] eq 'new DESTROY';
- ok @notes == 1;
+ $p->cleanup_register(\&set_cleanup, [$r, 'native scoped']);
+ }- # DESTROY should be a no-op on native pools
- my $p3 = $r->pool;
- $p3->cleanup_register(\&set_cleanup, [$r, 'native DESTROY']);
- $p3->DESTROY;
+ my @notes = $r->notes->get('cleanup');- @notes = $r->notes->get('cleanup');
- ok $notes[0] eq 'new DESTROY'; # same as before - no change
- ok @notes == 1;
+ ok t_cmp(0, scalar(@notes), "should be 0 notes");- # make sure lexical scoping destroys the pool
- {
- my $p4 = APR::Pool->new;
- $p4->cleanup_register(\&set_cleanup, [$r, 'new scoped']);
+ $r->notes->clear;
}- @notes = $r->notes->get('cleanup');
- ok $notes[0] eq 'new scoped';
- ok @notes == 1;- # but doesn't affect native pools
+ ### custom pools ###
+
+
+ # test: explicit pool object DESTROY destroys the custom pool
{
- my $p5 = $r->pool;
- $p5->cleanup_register(\&set_cleanup, [$r, 'native scoped']);
+ my $p = APR::Pool->new;
+
+ $p->cleanup_register(\&set_cleanup, [$r, 'new DESTROY']);
+
+ ok t_cmp(1, ancestry_count($p),
+ "a new pool has one ancestor: the global pool");
+
+ # explicity DESTROY the object
+ $p->DESTROY;
+
+ my @notes = $r->notes->get('cleanup');
+
+ ok t_cmp(1, scalar(@notes), "should be 1 note");
+
+ ok t_cmp('new DESTROY', $notes[0]);
+
+ $r->notes->clear;
+ }
+
+
+ # test: lexical scoping DESTROYs the custom pool
+ {
+ {
+ my $p = APR::Pool->new;
+
+ ok t_cmp(1, ancestry_count($p),
+ "a new pool has one ancestor: the global pool");
+
+ $p->cleanup_register(\&set_cleanup, [$r, 'new scoped']);
+ }
+
+ my @notes = $r->notes->get('cleanup');
+
+ ok t_cmp(1, scalar(@notes), "should be 1 note");
+
+ ok t_cmp('new scoped', $notes[0]);
+
+ $r->notes->clear;
+ }
+
+ ### custom pools + sub-pools ###
+
+ # test: basic pool and sub-pool tests + implicit destroy of pool objects
+ {
+ {
+ my ($pp, $sp) = both_pools_create_ok($r);
+ }
+
+ both_pools_destroy_ok($r);
+
+ $r->notes->clear;
+ }
+
+
+ # test: explicitly destroying a parent pool should destroy its
+ # sub-pool
+ {
+ my ($pp, $sp) = both_pools_create_ok($r);
+
+ # destroying $pp should destroy the subpool $sp too
+ $pp->DESTROY;
+
+ both_pools_destroy_ok($r);
+
+ $r->notes->clear;
+ }
+
+
+ # test: destroying a sub-pool before the parent pool
+ {
+ my ($pp, $sp) = both_pools_create_ok($r);
+
+ $sp->DESTROY;
+ $pp->DESTROY;
+
+ both_pools_destroy_ok($r);
+
+ $r->notes->clear;
+ }
+
+
+
+ # test: destroying a sub-pool explicitly after the parent pool
+ {
+ my ($pp, $sp) = both_pools_create_ok($r);
+
+ $pp->DESTROY;
+ $sp->DESTROY;
+
+ both_pools_destroy_ok($r);
+
+ $r->notes->clear;
}- @notes = $r->notes->get('cleanup');
- ok $notes[0] eq 'new scoped'; # same as before - no change
- ok @notes == 1; Apache::OK;
+}
+
+# returns how many ancestor generations the pool has (parent,
+# grandparent, etc.)
+sub ancestry_count {
+ my $child = shift;
+ my $gen = 0;
+ while (my $parent = $child->parent_get) {
+ # prevent possible endless loops
+ die "child pool reports to be its own parent, corruption!"
+ if $parent == $child;
+ $gen++;
+ die "child knows its parent, but the parent denies having that child"
+ unless $parent->is_ancestor($child);
+ $child = $parent;
+ }
+ return $gen;
+}
+
+
+sub add_cleanup {
+ my $arg = shift;
+ $arg->[0]->notes->add(cleanup => $arg->[1]);
+ 1;
+}
+
+sub set_cleanup {
+ my $arg = shift;
+ $arg->[0]->notes->set(cleanup => $arg->[1]);
+ 1;
+}
+
+# +4 tests
+sub both_pools_create_ok {
+ my $r = shift;
+
+ my $pp = APR::Pool->new;
+
+ ok t_cmp(1, $pp->isa('APR::Pool'), "isa('APR::Pool')");
+
+ ok t_cmp(1, ancestry_count($pp),
+ "a new pool has one ancestor: the global pool");
+
+ my $sp = $pp->new;
+
+ ok t_cmp(1, $sp->isa('APR::Pool'), "isa('APR::Pool')");
+
+ ok t_cmp(2, ancestry_count($sp),
+ "a subpool has 2 ancestors: the parent and global pools");
+
+ $pp->cleanup_register(\&add_cleanup, [$r, 'parent']);
+ $sp->cleanup_register(\&set_cleanup, [$r, 'child']);
+
+ return ($pp, $sp);
+
+}
+
+# +3 tests
+sub both_pools_destroy_ok {
+ my $r = shift;
+ my @notes = $r->notes->get('cleanup');
+
+ ok t_cmp(2, scalar(@notes), "should be 2 notes");
+ ok t_cmp('child', $notes[0]);
+ ok t_cmp('parent', $notes[1]);
}1; Index: xs/APR/Pool/APR__Pool.h =================================================================== RCS file: /home/cvs/modperl-2.0/xs/APR/Pool/APR__Pool.h,v retrieving revision 1.6 diff -u -r1.6 APR__Pool.h --- xs/APR/Pool/APR__Pool.h 9 Sep 2003 17:22:39 -0000 1.6 +++ xs/APR/Pool/APR__Pool.h 26 Sep 2003 00:31:12 -0000 @@ -1,22 +1,160 @@ #define MP_APR_POOL_NEW "APR::Pool::new"
+typedef struct {
+ int destroyable;
+ int ref_count;
+} mpxs_pool_account_t;
+
+static MP_INLINE void mpxs_apr_pool_destroyable_set(apr_pool_t *p)
+{
+ mpxs_pool_account_t *data;
+
+ apr_pool_userdata_get((void **)&data, MP_APR_POOL_NEW, p);
+ if (!data) {
+ data = (mpxs_pool_account_t *)apr_pcalloc(p, sizeof(*data));
+ }
+
+ data->destroyable++;
+
+ apr_pool_userdata_set(data, MP_APR_POOL_NEW, NULL, p);
+}
+
+static MP_INLINE void mpxs_apr_pool_destroyable_unset(apr_pool_t *p)
+{
+ mpxs_pool_account_t *data;
+
+ apr_pool_userdata_get((void **)&data, MP_APR_POOL_NEW, p);
+ if (!data) {
+ data = (mpxs_pool_account_t *)apr_pcalloc(p, sizeof(*data));
+ }
+
+ data->destroyable = 0;
+
+ apr_pool_userdata_set(data, MP_APR_POOL_NEW, NULL, p);
+}
+
+static MP_INLINE int mpxs_apr_pool_ref_count_inc(apr_pool_t *p)
+{
+ mpxs_pool_account_t *data;
+
+ apr_pool_userdata_get((void **)&data, MP_APR_POOL_NEW, p);
+ if (!data) {
+ data = (mpxs_pool_account_t *)apr_pcalloc(p, sizeof(*data));
+ }
+
+ data->ref_count++;
+
+ apr_pool_userdata_set(data, MP_APR_POOL_NEW, NULL, p);
+
+ return data->ref_count;
+}
+
+static MP_INLINE int mpxs_apr_pool_ref_count_dec(apr_pool_t *p)
+{
+ mpxs_pool_account_t *data;
+
+ apr_pool_userdata_get((void **)&data, MP_APR_POOL_NEW, p);
+ if (!data) {
+ data = (mpxs_pool_account_t *)apr_pcalloc(p, sizeof(*data));
+ }
+
+ if (data->ref_count > 0) {
+ data->ref_count--;
+ }
+
+ apr_pool_userdata_set(data, MP_APR_POOL_NEW, NULL, p);
+
+ return data->ref_count;
+}
+
+static MP_INLINE int mpxs_apr_pool_is_pool_destroyable(apr_pool_t *p)
+{
+ mpxs_pool_account_t *data;
+
+ apr_pool_userdata_get((void **)&data, MP_APR_POOL_NEW, p);
+ if (!data) {
+ data = (mpxs_pool_account_t *)apr_pcalloc(p, sizeof(*data));
+ }
+
+ return data->destroyable && !data->ref_count;
+}
+
+static MP_INLINE apr_status_t mpxs_apr_pool_unflag(void *data)
+{
+ /* unset the flag for the key MP_APR_POOL_NEW to prevent from
+ * apr_pool_destroy being called twice */
+ mpxs_apr_pool_destroyable_unset((apr_pool_t *)data);
+
+ return APR_SUCCESS;
+}
+
+
/**
- * create a new pool or subpool
- * @param obj an APR::Pool object or NULL
- * @return a new pool or subpool
+ * Create a new pool or subpool. Pass APR::Pool as an object if it's
+ * not a subpool.
+ * @param parent_pool_obj an APR::Pool object or NULL
+ * @return a new pool or subpool
*/
-static MP_INLINE apr_pool_t *mpxs_apr_pool_create(pTHX_ SV *obj)
+static MP_INLINE apr_pool_t *mpxs_apr_pool_create(pTHX_ SV *parent_pool_obj)
{
- apr_pool_t *parent = mpxs_sv_object_deref(obj, apr_pool_t);
- apr_pool_t *newpool = NULL;
- (void)apr_pool_create(&newpool, parent);
-
- /* mark the pool as being created via APR::Pool->new()
- * see mpxs_apr_pool_DESTROY */
- apr_pool_userdata_set((const void *)1, MP_APR_POOL_NEW,
- apr_pool_cleanup_null, newpool);
+ apr_pool_t *parent_pool = mpxs_sv_object_deref(parent_pool_obj, apr_pool_t);
+ apr_pool_t *child_pool = NULL;
+
+ (void)apr_pool_create(&child_pool, parent_pool);
+ Perl_warn(aTHX_ "==> MP_DEBUG: new pool 0x%lx\n", child_pool);
+
+#if APR_POOL_DEBUG
+ apr_pool_tag(child_pool, MP_APR_POOL_NEW);
+#endif
+
+ /* corruption validation */
+ if (child_pool == parent_pool) {
+ Perl_croak(aTHX_ "a newly allocated sub-pool 0x%lx "
+ "is the same as its parent 0x%lx, aborting",
+ (unsigned long)child_pool, (unsigned long)parent_pool);
+ }- return newpool;
+ /* mark the pool eligible for destruction. We aren't suppose to
+ * destroy pools not created by APR::Pool::new().
+ * see mpxs_apr_pool_DESTROY
+ */
+ mpxs_apr_pool_destroyable_set(child_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 their perl objects
+ */
+ apr_pool_cleanup_register(child_pool, (void *)child_pool,
+ mpxs_apr_pool_unflag,
+ apr_pool_cleanup_null);
+#if APR_POOL_DEBUG
+ /* child <-> parent <-> ... <-> top ancestry traversal */
+ {
+ apr_pool_t *p = child_pool;
+ apr_pool_t *pp;
+
+ while ((pp = apr_pool_parent_get(p))) {
+ Perl_warn(aTHX_ "==> MP_DEBUG: parent 0x%lx, child 0x%lx\n",
+ (unsigned long)pp, (unsigned long)p);
+
+ if (apr_pool_is_ancestor(pp, p)) {
+ Perl_warn(aTHX_ "==> MP_DEBUG: 0x%lx is a subpool of 0x%lx\n",
+ (unsigned long)p, (unsigned long)pp);
+ }
+ p = pp;
+ }
+ }
+#endif
+
+ mpxs_apr_pool_ref_count_inc(child_pool);
+ return child_pool;
} typedef struct {
@@ -111,26 +249,54 @@
apr_pool_cleanup_null);
}+
+static MP_INLINE apr_pool_t *
+mpxs_apr_pool_parent_get(pTHX_ apr_pool_t *child_pool)
+{
+ apr_pool_t *parent_pool = apr_pool_parent_get(child_pool);
+ if (parent_pool) {
+ mpxs_apr_pool_ref_count_inc(parent_pool);
+ }
+
+ return parent_pool;
+
+}
+
+
+
+
/**
* destroy a pool
* @param obj an APR::Pool object
*/
static MP_INLINE void mpxs_apr_pool_DESTROY(pTHX_ SV *obj) {- void *flag;
apr_pool_t *p;+ p = mpxs_sv_object_deref(obj, apr_pool_t);
+
+ mpxs_apr_pool_ref_count_dec(p);
+
/* APR::Pool::DESTROY
* we only want to call DESTROY on objects created by
* APR::Pool->new(), not objects representing native pools
* like r->pool. native pools can be destroyed using
- * apr_pool_destroy ($p->destroy) */
-
- p = mpxs_sv_object_deref(obj, apr_pool_t);
-
- apr_pool_userdata_get(&flag, MP_APR_POOL_NEW, p);
-
- if (flag) {
- apr_pool_destroy(p);
+ * apr_pool_destroy ($p->destroy)
+ */
+ if (mpxs_apr_pool_is_pool_destroyable(p)) {
+ Perl_warn(aTHX_ "==> MP_DEBUG: DESTROY pool 0x%lx\n", (unsigned long)p);
+ apr_pool_destroy(p);
+ /* mpxs_apr_pool_unflag called by apr_pool_destroy takes care
+ * of marking this pool as undestroyable, so we do it only once */
+ }
+ else {
+ /* either because we didn't create this pool (e.g., r->pool),
+ * or because this pool has already been destroyed via the
+ * destruction of the parent pool
+ */
+ Perl_warn(aTHX_ "==> MP_DEBUG: skipping DESTROY, "
+ "this object is not eligible to destroy pool 0x%lx\n",
+ (unsigned long)p);
+
}
}
Index: xs/maps/apr_functions.map
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/maps/apr_functions.map,v
retrieving revision 1.58
diff -u -r1.58 apr_functions.map
--- xs/maps/apr_functions.map 9 Sep 2003 17:22:39 -0000 1.58
+++ xs/maps/apr_functions.map 26 Sep 2003 00:31:12 -0000
@@ -157,7 +157,7 @@
apr_pool_destroy
DEFINE_DESTROY | mpxs_apr_pool_DESTROY | SV *:obj
>apr_pool_destroy_debug
- apr_pool_t *:DEFINE_new | mpxs_apr_pool_create | SV *:obj
+ apr_pool_t *:DEFINE_new | mpxs_apr_pool_create | SV *:parent_pool_obj
-apr_pool_create_ex
>apr_pool_create_ex_debug
!apr_pool_userdata_get
@@ -175,7 +175,7 @@
-apr_pmemdup
!apr_pool_child_cleanup_set
!apr_pool_abort_get
- apr_pool_parent_get
+ apr_pool_parent_get | mpxs_
apr_pool_is_ancestor
-apr_pool_abort_set
>apr_pool_initialize
Index: xs/tables/current/ModPerl/FunctionTable.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/tables/current/ModPerl/FunctionTable.pm,v
retrieving revision 1.122
diff -u -r1.122 FunctionTable.pm
--- xs/tables/current/ModPerl/FunctionTable.pm 9 Sep 2003 17:22:39 -0000 1.122
+++ xs/tables/current/ModPerl/FunctionTable.pm 26 Sep 2003 00:31:12 -0000
@@ -6429,6 +6429,24 @@
]
},
{
+ 'return_type' => 'apr_pool_t *',
+ 'name' => 'mpxs_apr_pool_parent_get',
+ 'attr' => [
+ 'static',
+ '__inline__'
+ ],
+ 'args' => [
+ {
+ 'type' => 'PerlInterpreter *',
+ 'name' => 'my_perl'
+ },
+ {
+ 'type' => 'apr_pool_t *',
+ 'name' => 'child_pool'
+ },
+ ]
+ },
+ {
'return_type' => 'void',
'name' => 'mpxs_apr_pool_DESTROY',
'attr' => [__________________________________________________________________ Stas Bekman JAm_pH ------> Just Another mod_perl Hacker http://stason.org/ mod_perl Guide ---> http://perl.apache.org mailto:[EMAIL PROTECTED] http://use.perl.org http://apacheweek.com http://modperlbook.org http://apache.org http://ticketmaster.com
--------------------------------------------------------------------- To unsubscribe, e-mail: [EMAIL PROTECTED] For additional commands, e-mail: [EMAIL PROTECTED]
