Re: the pools destruction issue solved

Strange, Randy says, the patch won't apply. The patch had no tabs, may be the 
mailer has messed it up. Here it is as an attachment.

__________________________________________________________________
Stas Bekman            JAm_pH ------> Just Another mod_perl Hacker
http://stason.org/     mod_perl Guide ---> http://perl.apache.org
mailto:stas@xxxxxxxxxx http://use.perl.org http://apacheweek.com
http://modperlbook.org http://apache.org   http://ticketmaster.com
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' => [

---------------------------------------------------------------------
To unsubscribe, e-mail: dev-unsubscribe@xxxxxxxxxxxxxxx
For additional commands, e-mail: dev-help@xxxxxxxxxxxxxxx