2_0_13/t/lib/TestAPRlib/pool.pm - mod_perl - Git at Google

 # please insert nothing before this line: -*- mode: cperl; cperl-indent-level: 4; cperl-continued-statement-offset: 4; indent-tabs-mode: nil -*-
 package TestAPRlib::pool;

 use strict;
 use warnings FATAL => 'all';

 use Apache::Test;
 use Apache::TestUtil;
 use Apache::TestTrace;

 use APR::Pool ();
 use APR::Table ();

 sub num_of_tests {
     return 77;
 }

 sub test {

     my $pool = APR::Pool->new();
     my $table = APR::Table::make($pool, 2);

     ### custom pools ###

     # test: explicit pool object destroy destroys the custom pool
     {
         my $p = APR::Pool->new;

         $p->cleanup_register(\&set_cleanup, [$table, 'new destroy']);

         ok t_cmp(ancestry_count($p), 1,
                  "a new pool has one ancestor: the global pool");

         # explicity destroy the object
         $p->destroy;

         my @notes = $table->get('cleanup');

         ok t_cmp(scalar(@notes), 1, "should be 1 note");

         ok t_cmp($notes[0], 'new destroy');

         $table->clear;
     }


     # test: lexical scoping DESTROYs the custom pool
     {
         {
             my $p = APR::Pool->new;

             ok t_cmp(ancestry_count($p), 1,
                  "a new pool has one ancestor: the global pool");

             $p->cleanup_register(\&set_cleanup, [$table, 'new scoped']);
         }

         my @notes = $table->get('cleanup');

         ok t_cmp(scalar(@notes), 1, "should be 1 note");

         ok t_cmp($notes[0], 'new scoped');

         $table->clear;
     }


     ### custom pools + sub-pools ###

     # test: basic pool and sub-pool tests + implicit destroy of pool objects
     {
         {
             my ($pp, $sp) = both_pools_create_ok($table);
         }

         both_pools_destroy_ok($table);

         $table->clear;
     }


     # test: explicitly destroying a parent pool should destroy its
     # sub-pool
     {
         my ($pp, $sp) = both_pools_create_ok($table);

         # destroying $pp should destroy the subpool $sp too
         $pp->destroy;

         both_pools_destroy_ok($table);

         $table->clear;
     }


     # test: destroying a sub-pool before the parent pool
     {
         my ($pp, $sp) = both_pools_create_ok($table);

         $sp->destroy;
         $pp->destroy;

         both_pools_destroy_ok($table);

         $table->clear;
     }


     # test: destroying a sub-pool explicitly after the parent pool destroy

     # the parent pool should have already destroyed the child pool, so
     # the object is invalid
     {
         my ($pp, $sp) = both_pools_create_ok($table);

         $pp->destroy;
         $sp->destroy;

         both_pools_destroy_ok($table);

         $table->clear;
     }


     # test: destroying a sub-pool before the parent pool and trying to
     # call APR::Pool methods on the a subpool object which points to a
     # destroyed pool
     {
         my ($pp, $sp) = both_pools_create_ok($table);

         # parent pool destroys child pool
         $pp->destroy;

         # this should "gracefully" fail, since $sp's guts were
         # destroyed when the parent pool was destroyed
         eval { $pp = $sp->parent_get };
         ok t_cmp($@,
                  qr/invalid pool object/,
                  "parent pool destroys child pool");

         # since pool $sp now contains 0 pointer, if we try to make a
         # new pool out of it, it's the same as APR->new (i.e. it'll
         # use the global top level pool for it), so the resulting pool
         # should have an ancestry length of exactly 1
         my $ssp = $sp->new;
         ok t_cmp(ancestry_count($ssp), 1,
                  "a new pool has one ancestor: the global pool");


         both_pools_destroy_ok($table);

         $table->clear;
     }

     # test: make sure that one pool won't destroy/affect another pool,
     # which happened to be allocated at the same memory address after
     # the pointer to the first pool was destroyed
     {
         my $pp2;
         {
             my $pp = APR::Pool->new;
             $pp->destroy;
             # $pp2 ideally should take the exact place of apr_pool
             # previously pointed to by $pp
             $pp2 = APR::Pool->new;
             # $pp object didn't go away yet (it'll when exiting this
             # scope). in the previous implementation, $pp will be
             # destroyed second time on the exit of the scope and it
             # could happen to work, because $pp2 pointer has allocated
             # exactly the same address. and if so it would have killed
             # the pool that $pp2 points to

             # this should "gracefully" fail, since $pp's guts were
             # destroyed when the parent pool was destroyed
             # must make sure that it won't try to hijack the new pool
             # $pp2 that (hopefully) took over $pp's place
             eval { $pp->parent_get };
             ok t_cmp($@,
                      qr/invalid pool object/,
                      "a dead pool is a dead pool");
         }

         # next make sure that $pp2's pool is still alive
         $pp2->cleanup_register(\&set_cleanup, [$table, 'overtake']);
         $pp2->destroy;

         my @notes = $table->get('cleanup');

         ok t_cmp(scalar(@notes), 1, "should be 1 note");
         ok t_cmp($notes[0], 'overtake');

         $table->clear;

     }

     # test: similar to the previous test, but this time, the parent
     # pool destroys the child pool. a second allocation of a new pair
     # of the parent and child pools take over exactly the same
     # allocations. so if there are any ghost objects, they must not
     # find the other pools and use them as they own. for example they
     # could destroy the pools, and the perl objects of the pair would
     # have no idea that someone has destroyed the pools without their
     # knowledge. the previous implementation suffered from this
     # problem. the new implementation uses an SV which is stored in
     # the object and in the pool. when the pool is destroyed the SV
     # gets its IVX pointer set to 0, which affects any perl object
     # that is a ref to that SV. so once an apr pool is destroyed all
     # perl objects pointing to it get automatically invalidated and
     # there is no risk of hijacking newly created pools that happen to
     # be at the same memory address.

     {
         my ($pp2, $sp2);
         {
             my $pp = APR::Pool->new;
             my $sp = $pp->new;
             # parent destroys $sp
             $pp->destroy;

             # hopefully these pool will take over the $pp and $sp
             # allocations
             ($pp2, $sp2) = both_pools_create_ok($table);
         }

         # $pp and $sp shouldn't have triggered any cleanups
         my @notes = $table->get('cleanup');
         ok t_cmp(scalar(@notes), 0, "should be 0 notes");
         $table->clear;

         # parent pool destroys child pool
         $pp2->destroy;

         both_pools_destroy_ok($table);

         $table->clear;
     }

     # test: only when the last references to the pool object is gone
     # it should get destroyed
     {

         my $cp;

         {
             my $sp = APR::Pool->new();

             $sp->cleanup_register(\&set_cleanup, [$table, 'several references']);

             $cp = $sp;
             # destroy of $sp shouldn't call apr_pool_destroy, because
             # $cp still references to it
         }

         my @notes = $table->get('cleanup');
         ok t_cmp(scalar(@notes), 0, "should be 0 notes");
         $table->clear;

         # now the last copy is gone and the cleanup hooks will be called
         $cp->destroy;

         @notes = $table->get('cleanup');
         ok t_cmp(scalar(@notes), 1, "should be 1 note");
         ok t_cmp($notes[0], 'several references');

         $table->clear;
     }
     {
         # and another variation
         my $pp = APR::Pool->new();
         my $sp = $pp->new;

         my $gp  = $pp->parent_get;
         my $pp2 = $sp->parent_get;

         # parent destroys children
         $pp->destroy;

         # grand parent ($pool) is undestroyable (core pool)
         $gp->destroy;

         # now all custom pools are destroyed - $sp and $pp2 point nowhere
         $pp2->destroy;
         $sp->destroy;

         ok 1;
     }

     # cleanup_register using a function name as a callback
     {
         {
             my $p = APR::Pool->new;
             $p->cleanup_register('set_cleanup', [$table, 'function name']);
         }

         my @notes = $table->get('cleanup');
         ok t_cmp($notes[0], 'function name', "function name callback");

         $table->clear;
     }

     # cleanup_register using an anon sub callback
     {
         {
             my $p = APR::Pool->new;

             $p->cleanup_register(sub { &set_cleanup }, [$table, 'anon sub']);
         }

         my @notes = $table->get('cleanup');
         ok t_cmp($notes[0], 'anon sub', "anon callback");

         $table->clear;
     }

     # registered callbacks are run in reversed order LIFO
     {
         {
             my $p = APR::Pool->new;

             $p->cleanup_register(\&add_cleanup, [$table, 'first']);
             $p->cleanup_register(\&add_cleanup, [$table, 'second']);
         }

         my @notes = $table->get('cleanup');
         ok t_cmp($notes[0], 'second', "two cleanup functions");
         ok t_cmp($notes[1], 'first',  "two cleanup functions");

         $table->clear;
     }

     # undefined cleanup subs
     {
         my $p = APR::Pool->new;
         $p->cleanup_register('TestAPR::pool::some_non_existing_sub', 1);

         my @warnings;
         local $SIG{__WARN__} = sub {push @warnings, @_};
         $p->destroy;

         ok t_cmp($warnings[0],
                  qr/Undefined subroutine/,
                  "non existing function");
     }
     {
         my $p = APR::Pool->new;
         $p->cleanup_register(\&non_existing1, 1);

         my @warnings;
         local $SIG{__WARN__} = sub {push @warnings, @_};
         $p->destroy;

         ok t_cmp($warnings[0],
                  qr/Undefined subroutine/,
                  "non existing function");
     }

     # cleanups throwing exceptions
     {
         my $p = APR::Pool->new;
         $p->cleanup_register(sub {die "1\n"}, 1);
         $p->cleanup_register(sub {die "2\n"}, 1);

         my @warnings;
         local $SIG{__WARN__} = sub {push @warnings, @_};
         local $@="to be preserved";
         undef $p;

         ok t_cmp(\@warnings,
                  [map "APR::Pool: cleanup died: $_\n", 2, 1],
                  "exceptions thrown by cleanups");
         ok t_cmp($@, "to be preserved", '$@ is preserved');
     }

     ### $p->clear ###
     {
         my ($pp, $sp) = both_pools_create_ok($table);
         $pp->clear;
         # both pools should have run their cleanups
         both_pools_destroy_ok($table);

         # sub-pool $sp should be now bogus, as clear() destroys
         # subpools
         eval { $sp->parent_get };
         ok t_cmp($@,
                  qr/invalid pool object/,
                  "clear destroys sub pools");

         # now we should be able to use the parent pool without
         # allocating it
         $pp->cleanup_register(\&set_cleanup, [$table, 're-using pool']);
         $pp->destroy;

         my @notes = $table->get('cleanup');
         ok t_cmp('re-using pool', $notes[0]);

         $table->clear;
     }


     # a pool can be tagged, so when doing low level apr_pool tracing
     # (when apr is compiled with -DAPR_POOL_DEBUG) it's possible to
     # grep(1) for a certain tag, so it's a useful method
     {
         my $p = APR::Pool->new;
         $p->tag("my pool");

         # though there is no way we can get back the value to test,
         # since there is no apr_pool_tag read accessor
         ok 1;
     }

     # out-of-scope pools
     {
         my $sp = APR::Pool->new->new;
         # the parent temp pool must stick around
         ok t_cmp(2, ancestry_count($sp),
                  "parent pool is still alive + global pool");
     }

     # other stuff
     {
         my $p = APR::Pool->new;

         # find some method that wants a pool object and try to pass it
         # an object that was already destroyed e.g. APR::Table::make($p, 2);

         # only available with -DAPR_POOL_DEBUG
         #my $num_bytes = $p->num_bytes;
         #ok $num_bytes;

     }
 }

 # 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->[1]";
     $arg->[0]->add(cleanup => $arg->[1]);
     1;
 }

 sub set_cleanup {
     my $arg = shift;
     debug "setting cleanup note: $arg->[1]";
     $arg->[0]->set(cleanup => $arg->[1]);
     1;
 }

 # +4 tests
 sub both_pools_create_ok {
     my $table = 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($sp->isa('APR::Pool'), 1, "isa('APR::Pool')");

     ok t_cmp(ancestry_count($sp), 2,
              "a subpool has 2 ancestors: the parent and global pools");

     $pp->cleanup_register(\&add_cleanup, [$table, 'parent']);
     $sp->cleanup_register(\&set_cleanup, [$table, 'child']);

     return ($pp, $sp);

 }

 # +3 tests
 sub both_pools_destroy_ok {
     my $table = shift;
     my @notes = $table->get('cleanup');

     ok t_cmp(scalar(@notes), 2, "should be 2 notes");
     ok t_cmp($notes[0], 'child');
     ok t_cmp($notes[1], 'parent');
 }

 1;
	# please insert nothing before this line: -- mode: cperl; cperl-indent-level: 4; cperl-continued-statement-offset: 4; indent-tabs-mode: nil --
	package TestAPRlib::pool;

	use strict;
	use warnings FATAL => 'all';

	use Apache::Test;
	use Apache::TestUtil;
	use Apache::TestTrace;

	use APR::Pool ();
	use APR::Table ();

	sub num_of_tests {
	return 77;
	}

	sub test {

	my $pool = APR::Pool->new();
	my $table = APR::Table::make($pool, 2);

	### custom pools ###

	# test: explicit pool object destroy destroys the custom pool
	{
	my $p = APR::Pool->new;

	$p->cleanup_register(\&set_cleanup, [$table, 'new destroy']);

	ok t_cmp(ancestry_count($p), 1,
	"a new pool has one ancestor: the global pool");

	# explicity destroy the object
	$p->destroy;

	my @notes = $table->get('cleanup');

	ok t_cmp(scalar(@notes), 1, "should be 1 note");

	ok t_cmp($notes[0], 'new destroy');

	$table->clear;
	}


	# test: lexical scoping DESTROYs the custom pool
	{
	{
	my $p = APR::Pool->new;

	ok t_cmp(ancestry_count($p), 1,
	"a new pool has one ancestor: the global pool");

	$p->cleanup_register(\&set_cleanup, [$table, 'new scoped']);
	}

	my @notes = $table->get('cleanup');

	ok t_cmp(scalar(@notes), 1, "should be 1 note");

	ok t_cmp($notes[0], 'new scoped');

	$table->clear;
	}



	### custom pools + sub-pools ###

	# test: basic pool and sub-pool tests + implicit destroy of pool objects
	{
	{
	my ($pp, $sp) = both_pools_create_ok($table);
	}

	both_pools_destroy_ok($table);

	$table->clear;
	}


	# test: explicitly destroying a parent pool should destroy its
	# sub-pool
	{
	my ($pp, $sp) = both_pools_create_ok($table);

	# destroying $pp should destroy the subpool $sp too
	$pp->destroy;

	both_pools_destroy_ok($table);

	$table->clear;
	}



	# test: destroying a sub-pool before the parent pool
	{
	my ($pp, $sp) = both_pools_create_ok($table);

	$sp->destroy;
	$pp->destroy;

	both_pools_destroy_ok($table);

	$table->clear;
	}


	# test: destroying a sub-pool explicitly after the parent pool destroy

	# the parent pool should have already destroyed the child pool, so
	# the object is invalid
	{
	my ($pp, $sp) = both_pools_create_ok($table);

	$pp->destroy;
	$sp->destroy;

	both_pools_destroy_ok($table);

	$table->clear;
	}


	# test: destroying a sub-pool before the parent pool and trying to
	# call APR::Pool methods on the a subpool object which points to a
	# destroyed pool
	{
	my ($pp, $sp) = both_pools_create_ok($table);

	# parent pool destroys child pool
	$pp->destroy;

	# this should "gracefully" fail, since $sp's guts were
	# destroyed when the parent pool was destroyed
	eval { $pp = $sp->parent_get };
	ok t_cmp($@,
	qr/invalid pool object/,
	"parent pool destroys child pool");

	# since pool $sp now contains 0 pointer, if we try to make a
	# new pool out of it, it's the same as APR->new (i.e. it'll
	# use the global top level pool for it), so the resulting pool
	# should have an ancestry length of exactly 1
	my $ssp = $sp->new;
	ok t_cmp(ancestry_count($ssp), 1,
	"a new pool has one ancestor: the global pool");


	both_pools_destroy_ok($table);

	$table->clear;
	}

	# test: make sure that one pool won't destroy/affect another pool,
	# which happened to be allocated at the same memory address after
	# the pointer to the first pool was destroyed
	{
	my $pp2;
	{
	my $pp = APR::Pool->new;
	$pp->destroy;
	# $pp2 ideally should take the exact place of apr_pool
	# previously pointed to by $pp
	$pp2 = APR::Pool->new;
	# $pp object didn't go away yet (it'll when exiting this
	# scope). in the previous implementation, $pp will be
	# destroyed second time on the exit of the scope and it
	# could happen to work, because $pp2 pointer has allocated
	# exactly the same address. and if so it would have killed
	# the pool that $pp2 points to

	# this should "gracefully" fail, since $pp's guts were
	# destroyed when the parent pool was destroyed
	# must make sure that it won't try to hijack the new pool
	# $pp2 that (hopefully) took over $pp's place
	eval { $pp->parent_get };
	ok t_cmp($@,
	qr/invalid pool object/,
	"a dead pool is a dead pool");
	}

	# next make sure that $pp2's pool is still alive
	$pp2->cleanup_register(\&set_cleanup, [$table, 'overtake']);
	$pp2->destroy;

	my @notes = $table->get('cleanup');

	ok t_cmp(scalar(@notes), 1, "should be 1 note");
	ok t_cmp($notes[0], 'overtake');

	$table->clear;

	}

	# test: similar to the previous test, but this time, the parent
	# pool destroys the child pool. a second allocation of a new pair
	# of the parent and child pools take over exactly the same
	# allocations. so if there are any ghost objects, they must not
	# find the other pools and use them as they own. for example they
	# could destroy the pools, and the perl objects of the pair would
	# have no idea that someone has destroyed the pools without their
	# knowledge. the previous implementation suffered from this
	# problem. the new implementation uses an SV which is stored in
	# the object and in the pool. when the pool is destroyed the SV
	# gets its IVX pointer set to 0, which affects any perl object
	# that is a ref to that SV. so once an apr pool is destroyed all
	# perl objects pointing to it get automatically invalidated and
	# there is no risk of hijacking newly created pools that happen to
	# be at the same memory address.

	{
	my ($pp2, $sp2);
	{
	my $pp = APR::Pool->new;
	my $sp = $pp->new;
	# parent destroys $sp
	$pp->destroy;

	# hopefully these pool will take over the $pp and $sp
	# allocations
	($pp2, $sp2) = both_pools_create_ok($table);
	}

	# $pp and $sp shouldn't have triggered any cleanups
	my @notes = $table->get('cleanup');
	ok t_cmp(scalar(@notes), 0, "should be 0 notes");
	$table->clear;

	# parent pool destroys child pool
	$pp2->destroy;

	both_pools_destroy_ok($table);

	$table->clear;
	}

	# test: only when the last references to the pool object is gone
	# it should get destroyed
	{

	my $cp;

	{
	my $sp = APR::Pool->new();

	$sp->cleanup_register(\&set_cleanup, [$table, 'several references']);

	$cp = $sp;
	# destroy of $sp shouldn't call apr_pool_destroy, because
	# $cp still references to it
	}

	my @notes = $table->get('cleanup');
	ok t_cmp(scalar(@notes), 0, "should be 0 notes");
	$table->clear;

	# now the last copy is gone and the cleanup hooks will be called
	$cp->destroy;

	@notes = $table->get('cleanup');
	ok t_cmp(scalar(@notes), 1, "should be 1 note");
	ok t_cmp($notes[0], 'several references');

	$table->clear;
	}
	{
	# and another variation
	my $pp = APR::Pool->new();
	my $sp = $pp->new;

	my $gp = $pp->parent_get;
	my $pp2 = $sp->parent_get;

	# parent destroys children
	$pp->destroy;

	# grand parent ($pool) is undestroyable (core pool)
	$gp->destroy;

	# now all custom pools are destroyed - $sp and $pp2 point nowhere
	$pp2->destroy;
	$sp->destroy;

	ok 1;
	}

	# cleanup_register using a function name as a callback
	{
	{
	my $p = APR::Pool->new;
	$p->cleanup_register('set_cleanup', [$table, 'function name']);
	}

	my @notes = $table->get('cleanup');
	ok t_cmp($notes[0], 'function name', "function name callback");

	$table->clear;
	}

	# cleanup_register using an anon sub callback
	{
	{
	my $p = APR::Pool->new;

	$p->cleanup_register(sub { &set_cleanup }, [$table, 'anon sub']);
	}

	my @notes = $table->get('cleanup');
	ok t_cmp($notes[0], 'anon sub', "anon callback");

	$table->clear;
	}

	# registered callbacks are run in reversed order LIFO
	{
	{
	my $p = APR::Pool->new;

	$p->cleanup_register(\&add_cleanup, [$table, 'first']);
	$p->cleanup_register(\&add_cleanup, [$table, 'second']);
	}

	my @notes = $table->get('cleanup');
	ok t_cmp($notes[0], 'second', "two cleanup functions");
	ok t_cmp($notes[1], 'first', "two cleanup functions");

	$table->clear;
	}

	# undefined cleanup subs
	{
	my $p = APR::Pool->new;
	$p->cleanup_register('TestAPR::pool::some_non_existing_sub', 1);

	my @warnings;
	local $SIG{__WARN__} = sub {push @warnings, @_};
	$p->destroy;

	ok t_cmp($warnings[0],
	qr/Undefined subroutine/,
	"non existing function");
	}
	{
	my $p = APR::Pool->new;
	$p->cleanup_register(\&non_existing1, 1);

	my @warnings;
	local $SIG{__WARN__} = sub {push @warnings, @_};
	$p->destroy;

	ok t_cmp($warnings[0],
	qr/Undefined subroutine/,
	"non existing function");
	}

	# cleanups throwing exceptions
	{
	my $p = APR::Pool->new;
	$p->cleanup_register(sub {die "1\n"}, 1);
	$p->cleanup_register(sub {die "2\n"}, 1);

	my @warnings;
	local $SIG{__WARN__} = sub {push @warnings, @_};
	local $@="to be preserved";
	undef $p;

	ok t_cmp(\@warnings,
	[map "APR::Pool: cleanup died: $_\n", 2, 1],
	"exceptions thrown by cleanups");
	ok t_cmp($@, "to be preserved", '$@ is preserved');
	}

	### $p->clear ###
	{
	my ($pp, $sp) = both_pools_create_ok($table);
	$pp->clear;
	# both pools should have run their cleanups
	both_pools_destroy_ok($table);

	# sub-pool $sp should be now bogus, as clear() destroys
	# subpools
	eval { $sp->parent_get };
	ok t_cmp($@,
	qr/invalid pool object/,
	"clear destroys sub pools");

	# now we should be able to use the parent pool without
	# allocating it
	$pp->cleanup_register(\&set_cleanup, [$table, 're-using pool']);
	$pp->destroy;

	my @notes = $table->get('cleanup');
	ok t_cmp('re-using pool', $notes[0]);

	$table->clear;
	}


	# a pool can be tagged, so when doing low level apr_pool tracing
	# (when apr is compiled with -DAPR_POOL_DEBUG) it's possible to
	# grep(1) for a certain tag, so it's a useful method
	{
	my $p = APR::Pool->new;
	$p->tag("my pool");

	# though there is no way we can get back the value to test,
	# since there is no apr_pool_tag read accessor
	ok 1;
	}

	# out-of-scope pools
	{
	my $sp = APR::Pool->new->new;
	# the parent temp pool must stick around
	ok t_cmp(2, ancestry_count($sp),
	"parent pool is still alive + global pool");
	}

	# other stuff
	{
	my $p = APR::Pool->new;

	# find some method that wants a pool object and try to pass it
	# an object that was already destroyed e.g. APR::Table::make($p, 2);

	# only available with -DAPR_POOL_DEBUG
	#my $num_bytes = $p->num_bytes;
	#ok $num_bytes;

	}
	}

	# 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->[1]";
	$arg->[0]->add(cleanup => $arg->[1]);
	1;
	}

	sub set_cleanup {
	my $arg = shift;
	debug "setting cleanup note: $arg->[1]";
	$arg->[0]->set(cleanup => $arg->[1]);
	1;
	}

	# +4 tests
	sub both_pools_create_ok {
	my $table = 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($sp->isa('APR::Pool'), 1, "isa('APR::Pool')");

	ok t_cmp(ancestry_count($sp), 2,
	"a subpool has 2 ancestors: the parent and global pools");

	$pp->cleanup_register(\&add_cleanup, [$table, 'parent']);
	$sp->cleanup_register(\&set_cleanup, [$table, 'child']);

	return ($pp, $sp);

	}

	# +3 tests
	sub both_pools_destroy_ok {
	my $table = shift;
	my @notes = $table->get('cleanup');

	ok t_cmp(scalar(@notes), 2, "should be 2 notes");
	ok t_cmp($notes[0], 'child');
	ok t_cmp($notes[1], 'parent');
	}

	1;