randyk 2004/07/15 08:33:37
Modified: t/response/TestAPR pool.pm Added: t/apr-ext pool.t t/lib/TestAPRlib pool.pm Log: Reviewed by: stas put common pool tests under t/lib/TestAPRlib/, and call them from both t/apr/ and t/apr-ext/. Revision Changes Path 1.1 modperl-2.0/t/apr-ext/pool.t Index: pool.t =================================================================== use strict; use warnings FATAL => 'all'; use Apache::Test; use TestAPRlib::pool; plan tests => TestAPRlib::pool::num_of_tests(); TestAPRlib::pool::test(); 1.1 modperl-2.0/t/lib/TestAPRlib/pool.pm Index: pool.pm =================================================================== package TestAPRlib::pool; use strict; use warnings FATAL => 'all'; use Apache::Test; use Apache::TestUtil; use Apache::TestTrace; use APR::Pool (); use APR::Table (); use APR::Table (); sub num_of_tests { return 65; } 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); eval { $p->destroy }; ok t_cmp($@, qr/Undefined subroutine/, "non existing function"); } { my $p = APR::Pool->new; $p->cleanup_register(\&non_existing1, 1); eval { $p->destroy }; ok t_cmp($@, qr/Undefined subroutine/, "non existing function"); } # XXX: on windows $pool->clean, followed by $pool->destroy breaks # other tests. on unix it works fine. # # ### $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; } # 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; 1.18 +6 -448 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.17 retrieving revision 1.18 diff -u -r1.17 -r1.18 --- pool.pm 8 Jul 2004 06:06:33 -0000 1.17 +++ pool.pm 15 Jul 2004 15:33:37 -0000 1.18 @@ -13,10 +13,12 @@ use Apache::Const -compile => 'OK'; +use TestAPRlib::pool; + sub handler { my $r = shift; - plan $r, tests => 69; + plan $r, tests => 4 + TestAPRlib::pool::num_of_tests(); ### native pools ### @@ -24,7 +26,7 @@ { my $p = $r->pool; - my $count = ancestry_count($p); + my $count = TestAPRlib::pool::ancestry_count($p); t_debug "\$r->pool has 2 or more ancestors (found $count)"; ok $count >= 2; @@ -45,7 +47,7 @@ { my $p = $r->pool; - my $count = ancestry_count($p); + my $count = TestAPRlib::pool::ancestry_count($p); t_debug "\$r->pool has 2 or more ancestors (found $count)"; ok $count >= 2; @@ -59,421 +61,11 @@ $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(ancestry_count($p), 1, - "a new pool has one ancestor: the global pool"); - - # explicity destroy the object - $p->destroy; - - my @notes = $r->notes->get('cleanup'); - - ok t_cmp(scalar(@notes), 1, "should be 1 note"); - - ok t_cmp($notes[0], 'new destroy'); - - $r->notes->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, [$r, 'new scoped']); - } - - my @notes = $r->notes->get('cleanup'); - - ok t_cmp(scalar(@notes), 1, "should be 1 note"); - - ok t_cmp($notes[0], 'new scoped'); - - $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 destroy - - # the parent pool should have already destroyed the child pool, so - # the object is invalid - { - my ($pp, $sp) = both_pools_create_ok($r); - - $pp->destroy; - $sp->destroy; - - both_pools_destroy_ok($r); - - $r->notes->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($r); - - # 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($r); - - $r->notes->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, [$r, 'overtake']); - $pp2->destroy; - - my @notes = $r->notes->get('cleanup'); - - ok t_cmp(scalar(@notes), 1, "should be 1 note"); - ok t_cmp($notes[0], 'overtake'); - - $r->notes->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($r); - } - - # $pp and $sp shouldn't have triggered any cleanups - my @notes = $r->notes->get('cleanup'); - ok t_cmp(scalar(@notes), 0, "should be 0 notes"); - $r->notes->clear; - - # parent pool destroys child pool - $pp2->destroy; - - both_pools_destroy_ok($r); - - $r->notes->clear; - } - - # test: only when the last references to the pool object is gone - # it should get destroyed - { - - my $cp; - - { - my $sp = $r->pool->new; - - $sp->cleanup_register(\&set_cleanup, [$r, 'several references']); - - $cp = $sp; - # destroy of $sp shouldn't call apr_pool_destroy, because - # $cp still references to it - } - - my @notes = $r->notes->get('cleanup'); - ok t_cmp(scalar(@notes), 0, "should be 0 notes"); - $r->notes->clear; - - # now the last copy is gone and the cleanup hooks will be called - $cp->destroy; - - @notes = $r->notes->get('cleanup'); - ok t_cmp(scalar(@notes), 1, "should be 1 note"); - ok t_cmp($notes[0], 'several references'); - - $r->notes->clear; - } - { - # and another variation - my $pp = $r->pool->new; - my $sp = $pp->new; - - my $gp = $pp->parent_get; - my $pp2 = $sp->parent_get; - - # parent destroys children - $pp->destroy; - - # grand parent ($r->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', [$r, 'function name']); - } - - my @notes = $r->notes->get('cleanup'); - ok t_cmp($notes[0], 'function name', "function name callback"); - - $r->notes->clear; - } - - # cleanup_register using an anon sub callback - { - { - my $p = APR::Pool->new; - - $p->cleanup_register(sub { &set_cleanup }, [$r, 'anon sub']); - } - - my @notes = $r->notes->get('cleanup'); - ok t_cmp($notes[0], 'anon sub', "anon callback"); - - $r->notes->clear; - } - - # registered callbacks are run in reversed order LIFO - { - { - my $p = APR::Pool->new; - - $p->cleanup_register(\&add_cleanup, [$r, 'first']); - $p->cleanup_register(\&add_cleanup, [$r, 'second']); - } - - my @notes = $r->notes->get('cleanup'); - ok t_cmp($notes[0], 'second', "two cleanup functions"); - ok t_cmp($notes[1], 'first', "two cleanup functions"); - - $r->notes->clear; - } - - # undefined cleanup subs - { - my $p = APR::Pool->new; - $p->cleanup_register('TestAPR::pool::some_non_existing_sub', 1); - eval { $p->destroy }; - ok t_cmp($@, - qr/Undefined subroutine/, - "non existing function"); - } - { - my $p = APR::Pool->new; - $p->cleanup_register(\&non_existing1, 1); - eval { $p->destroy }; - ok t_cmp($@, - qr/Undefined subroutine/, - "non existing function"); - } - -# XXX: on windows $pool->clean, followed by $pool->destroy breaks -# other tests. on unix it works fine. -# -# ### $p->clear ### -# { -# my ($pp, $sp) = both_pools_create_ok($r); -# $pp->clear; -# # both pools should have run their cleanups -# both_pools_destroy_ok($r); -# -# # 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, [$r, 're-using pool']); -# $pp->destroy; -# -# my @notes = $r->notes->get('cleanup'); -# ok t_cmp('re-using pool', $notes[0]); -# -# $r->notes->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; - } - - - - - # 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; - - } + TestAPRlib::pool::test(); 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->[1]"; - $arg->[0]->notes->add(cleanup => $arg->[1]); - 1; -} - sub set_cleanup { my $arg = shift; debug "setting cleanup note: $arg->[1]"; @@ -481,39 +73,5 @@ 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($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, [$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(scalar(@notes), 2, "should be 2 notes"); - ok t_cmp($notes[0], 'child'); - ok t_cmp($notes[1], 'parent'); -} 1;