[prev in list] [next in list] [prev in thread] [next in thread]
List: apache-modperl-cvs
Subject: cvs commit: modperl-2.0 Changes
From: stas () apache ! org
Date: 2003-09-26 8:29:27
[Download RAW message or body]
stas 2003/09/26 01:29:27
Modified: t/response/TestAPR pool.pm
xs/APR/Pool APR__Pool.h
xs/maps apr_functions.map
xs/tables/current/ModPerl FunctionTable.pm
. Changes
Log:
make sure that the custom pools and destroyed only once and only when
all references went out of scope
Revision Changes Path
1.6 +196 -55 modperl-2.0/t/response/TestAPR/pool.pm
Index: pool.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/response/TestAPR/pool.pm,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -u -r1.5 -r1.6
--- pool.pm 9 Sep 2003 17:22:39 -0000 1.5
+++ pool.pm 26 Sep 2003 08:29:26 -0000 1.6
@@ -4,6 +4,8 @@
use warnings FATAL => 'all';
use Apache::Test;
+use Apache::TestUtil;
+use Apache::TestTrace;
use Apache::RequestRec ();
use APR::Pool ();
@@ -11,85 +13,224 @@
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;
+
+ ok t_cmp(5, ancestry_count($p), "\$r->pool has 5 ancestors");
+
+ $p->cleanup_register(\&set_cleanup, [$r, 'native scoped']);
+ }
+
+ my @notes = $r->notes->get('cleanup');
+
+ ok t_cmp(0, scalar(@notes), "should be 0 notes");
+
+ $r->notes->clear;
+ }
+
+
+ ### custom pools ###
+
+
+ # test: explicit pool object DESTROY destroys the custom pool
+ {
+ 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;
+ }
- # explicity DESTROY the objects
- my $p2 = APR::Pool->new;
- $p2->cleanup_register(\&set_cleanup, [$r, 'new DESTROY']);
- $p2->DESTROY;
- @notes = $r->notes->get('cleanup');
- ok $notes[0] eq 'new DESTROY';
- ok @notes == 1;
+ # test: explicitly destroying a parent pool should destroy its
+ # sub-pool
+ {
+ my ($pp, $sp) = both_pools_create_ok($r);
- # DESTROY should be a no-op on native pools
- my $p3 = $r->pool;
- $p3->cleanup_register(\&set_cleanup, [$r, 'native DESTROY']);
- $p3->DESTROY;
+ # destroying $pp should destroy the subpool $sp too
+ $pp->DESTROY;
- @notes = $r->notes->get('cleanup');
- ok $notes[0] eq 'new DESTROY'; # same as before - no change
- ok @notes == 1;
+ both_pools_destroy_ok($r);
- # 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
+ # test: destroying a sub-pool before the parent pool
{
- my $p5 = $r->pool;
- $p5->cleanup_register(\&set_cleanup, [$r, 'native scoped']);
+ my ($pp, $sp) = both_pools_create_ok($r);
+
+ $sp->DESTROY;
+ $pp->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;
+
+
+ # 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;
+ }
+
+ # other stuff
+ {
+ my $p = APR::Pool->new;
+
+ # only available with -DAPR_POOL_DEBUG
+ #my $num_bytes = $p->num_bytes;
+ #ok $num_bytes;
+
+ }
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;
+ debug "adding cleanup note";
+ $arg->[0]->notes->add(cleanup => $arg->[1]);
+ 1;
+}
+
+sub set_cleanup {
+ my $arg = shift;
+ debug "setting cleanup note";
+ $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;
1.7 +209 -22 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.6
retrieving revision 1.7
diff -u -u -r1.6 -r1.7
--- APR__Pool.h 9 Sep 2003 17:22:39 -0000 1.6
+++ APR__Pool.h 26 Sep 2003 08:29:26 -0000 1.7
@@ -1,22 +1,175 @@
#define MP_APR_POOL_NEW "APR::Pool::new"
+typedef struct {
+ int destroyable;
+ int ref_count;
+} mpxs_pool_account_t;
+
+/* XXX: should we make it a new global tracing category
+ * MOD_PERL_TRACE=p for tracing pool management? */
+#define MP_POOL_TRACE_DO 0
+
+#if MP_POOL_TRACE_DO && defined(MP_TRACE)
+#define MP_POOL_TRACE modperl_trace
+#else
+#define MP_POOL_TRACE if (0) modperl_trace
+#endif
+
+
+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) {
+ /* if there is no data, there is nothing to decrement */
+ return 0;
+ }
+
+ 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 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) {
+ /* if there is no data, there is nothing to unset */
+ return;
+ }
+
+ data->destroyable = 0;
+
+ apr_pool_userdata_set(data, MP_APR_POOL_NEW, NULL, p);
+}
+
+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_cleanup_destroyable_unset(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.
+ * @param parent_pool_obj an APR::Pool object or an "APR::Pool" class
+ * @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);
+ MP_POOL_TRACE(MP_FUNC, "new pool 0x%lx\n", child_pool);
+
+#if APR_POOL_DEBUG
+ /* useful for pools debugging, can grep for APR::Pool::new */
+ apr_pool_tag(child_pool, MP_APR_POOL_NEW);
+#endif
+
+ /* allocation corruption validation: I saw this happening when the
+ * same pool was destroyed more than once, should be fixed now,
+ * but still the check is not redundant */
+ 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);
+ }
+
+ /* 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_cleanup_destroyable_unset,
+ 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))) {
+ MP_POOL_TRACE(MP_FUNC, "parent 0x%lx, child 0x%lx\n",
+ (unsigned long)pp, (unsigned long)p);
+
+ if (apr_pool_is_ancestor(pp, p)) {
+ MP_POOL_TRACE(MP_FUNC, "0x%lx is a subpool of 0x%lx\n",
+ (unsigned long)p, (unsigned long)pp);
+ }
+ p = pp;
+ }
+ }
+#endif
- return newpool;
+ mpxs_apr_pool_ref_count_inc(child_pool);
+ return child_pool;
}
typedef struct {
@@ -111,26 +264,60 @@
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) {
+ /* 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_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)) {
+ MP_POOL_TRACE(MP_FUNC, "DESTROY pool 0x%lx\n", (unsigned long)p);
+ apr_pool_destroy(p);
+ /* mpxs_apr_pool_cleanup_destroyable_unset 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
+ */
+ MP_POOL_TRACE(MP_FUNC, "skipping DESTROY, "
+ "this object is not eligible to destroy pool 0x%lx\n",
+ (unsigned long)p);
+
}
}
1.59 +2 -2 modperl-2.0/xs/maps/apr_functions.map
Index: apr_functions.map
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/maps/apr_functions.map,v
retrieving revision 1.58
retrieving revision 1.59
diff -u -u -r1.58 -r1.59
--- apr_functions.map 9 Sep 2003 17:22:39 -0000 1.58
+++ apr_functions.map 26 Sep 2003 08:29:26 -0000 1.59
@@ -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
1.123 +18 -0 modperl-2.0/xs/tables/current/ModPerl/FunctionTable.pm
Index: FunctionTable.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/tables/current/ModPerl/FunctionTable.pm,v
retrieving revision 1.122
retrieving revision 1.123
diff -u -u -r1.122 -r1.123
--- FunctionTable.pm 9 Sep 2003 17:22:39 -0000 1.122
+++ FunctionTable.pm 26 Sep 2003 08:29:26 -0000 1.123
@@ -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' => [
1.221 +3 -0 modperl-2.0/Changes
Index: Changes
===================================================================
RCS file: /home/cvs/modperl-2.0/Changes,v
retrieving revision 1.220
retrieving revision 1.221
diff -u -u -r1.220 -r1.221
--- Changes 23 Sep 2003 23:52:49 -0000 1.220
+++ Changes 26 Sep 2003 08:29:26 -0000 1.221
@@ -12,6 +12,9 @@
=item 1.99_10-dev
+make sure that the custom pools and destroyed only once and only when
+all references went out of scope [Stas]
+
($r|$c)->add_(input|output)_filter(\&handler) now verify that the
filter of the right kind is passed and will refuse to add a request
filter as a connection filter and vice versa. The request filter
[prev in list] [next in list] [prev in thread] [next in thread]
Configure |
About |
News |
Add a list |
Sponsored by KoreLogic