stas 2004/05/14 00:40:31
Modified: t/response/TestAPR pool.pm
xs/APR/Pool APR__Pool.h
xs/maps apr_functions.map
xs/tables/current/ModPerl FunctionTable.pm
Log:
APR::Pool now has destroy() and clear() available + tests
Revision Changes Path
1.11 +56 -26 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.10
retrieving revision 1.11
diff -u -u -r1.10 -r1.11
--- pool.pm 14 May 2004 02:58:41 -0000 1.10
+++ pool.pm 14 May 2004 07:40:31 -0000 1.11
@@ -16,11 +16,11 @@
sub handler {
my $r = shift;
- plan $r, tests => 66;
+ plan $r, tests => 75;
### native pools ###
- # explicit DESTROY shouldn't destroy native pools
+ # explicit destroy shouldn't destroy native pools
{
my $p = $r->pool;
@@ -28,9 +28,9 @@
t_debug "\$r->pool has 2 or more ancestors (found $count)";
ok $count >= 2;
- $p->cleanup_register(\&set_cleanup, [$r, 'native DESTROY']);
+ $p->cleanup_register(\&set_cleanup, [$r, 'native destroy']);
- $p->DESTROY;
+ $p->destroy;
my @notes = $r->notes->get('cleanup');
@@ -63,23 +63,23 @@
### custom pools ###
- # test: explicit pool object DESTROY destroys the custom pool
+ # test: explicit pool object destroy destroys the custom pool
{
my $p = APR::Pool->new;
- $p->cleanup_register(\&set_cleanup, [$r, 'new DESTROY']);
+ $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;
+ # 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]);
+ ok t_cmp('new destroy', $notes[0]);
$r->notes->clear;
}
@@ -128,7 +128,7 @@
my ($pp, $sp) = both_pools_create_ok($r);
# destroying $pp should destroy the subpool $sp too
- $pp->DESTROY;
+ $pp->destroy;
both_pools_destroy_ok($r);
@@ -141,8 +141,8 @@
{
my ($pp, $sp) = both_pools_create_ok($r);
- $sp->DESTROY;
- $pp->DESTROY;
+ $sp->destroy;
+ $pp->destroy;
both_pools_destroy_ok($r);
@@ -157,8 +157,8 @@
{
my ($pp, $sp) = both_pools_create_ok($r);
- $pp->DESTROY;
- $sp->DESTROY;
+ $pp->destroy;
+ $sp->destroy;
both_pools_destroy_ok($r);
@@ -173,7 +173,7 @@
my ($pp, $sp) = both_pools_create_ok($r);
# parent pool destroys child pool
- $pp->DESTROY;
+ $pp->destroy;
# this should "gracefully" fail, since $sp's guts were
# destroyed when the parent pool was destroyed
@@ -203,13 +203,13 @@
my $pp2;
{
my $pp = APR::Pool->new;
- $pp->DESTROY;
+ $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
- # DESTROY'ed second time on the exit of the scope and it
+ # 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
@@ -226,7 +226,7 @@
# next make sure that $pp2's pool is still alive
$pp2->cleanup_register(\&set_cleanup, [$r, 'overtake']);
- $pp2->DESTROY;
+ $pp2->destroy;
my @notes = $r->notes->get('cleanup');
@@ -259,7 +259,7 @@
my $pp = APR::Pool->new;
my $sp = $pp->new;
# parent destroys $sp
- $pp->DESTROY;
+ $pp->destroy;
# hopefully these pool will take over the $pp and $sp
# allocations
@@ -272,7 +272,7 @@
$r->notes->clear;
# parent pool destroys child pool
- $pp2->DESTROY;
+ $pp2->destroy;
both_pools_destroy_ok($r);
@@ -300,7 +300,7 @@
$r->notes->clear;
# now the last copy is gone and the cleanup hooks will be called
- $cp->DESTROY;
+ $cp->destroy;
@notes = $r->notes->get('cleanup');
ok t_cmp(1, scalar(@notes), "should be 1 note");
@@ -308,7 +308,6 @@
$r->notes->clear;
}
-
{
# and another variation
my $pp = $r->pool->new;
@@ -318,14 +317,14 @@
my $pp2 = $sp->parent_get;
# parent destroys children
- $pp->DESTROY;
+ $pp->destroy;
# grand parent ($r->pool) is undestroyable (core pool)
- $gp->DESTROY;
+ $gp->destroy;
# now all custom pools are destroyed - $sp and $pp2 point nowhere
- $pp2->DESTROY;
- $sp->DESTROY;
+ $pp2->destroy;
+ $sp->destroy;
ok 1;
}
@@ -388,6 +387,37 @@
t_server_log_error_is_expected();
$p->cleanup_register(\&non_existing1, 1);
}
+
+ ### $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;
+ }
+
+
+
+
+
+
# other stuff
{
1.14 +33 -0 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.13
retrieving revision 1.14
diff -u -u -r1.13 -r1.14
--- APR__Pool.h 14 May 2004 02:37:28 -0000 1.13
+++ APR__Pool.h 14 May 2004 07:40:31 -0000 1.14
@@ -155,6 +155,39 @@
}
}
+static MP_INLINE void mpxs_APR__Pool_clear(pTHX_ SV *obj)
+{
+ apr_pool_t *p = mp_xs_sv2_APR__Pool(obj);
+ mpxs_pool_account_t *data;
+
+ apr_pool_userdata_get((void **)&data, MP_APR_POOL_NEW, p);
+ if (!(data && data->sv)) {
+ MP_POOL_TRACE(MP_FUNC, "parent pool (0x%lx) is a core pool",
+ (unsigned long)p);
+ apr_pool_clear(p);
+ return;
+ }
+
+ MP_POOL_TRACE(MP_FUNC,
+ "parent pool (0x%lx) is a custom pool, sv 0x%lx",
+ (unsigned long)p,
+ (unsigned long)data->sv);
+
+ apr_pool_clear(p);
+
+ /* apr_pool_clear removes all the user data, so we need to restore
+ * it. Since clear triggers mpxs_apr_pool_cleanup call, our
+ * object's guts get nuked too, so we need to restore them too */
+
+ /* this is sv_setref_pv, but for an existing object */
+ sv_setiv(newSVrv(obj, "APR::Pool"), PTR2IV((void*)p));
+ data->sv = SvRV(obj);
+
+ /* reinstall the user data */
+ apr_pool_userdata_set(data, MP_APR_POOL_NEW, NULL, p);
+}
+
+
typedef struct {
SV *cv;
SV *arg;
1.74 +4 -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.73
retrieving revision 1.74
diff -u -u -r1.73 -r1.74
--- apr_functions.map 4 May 2004 06:14:44 -0000 1.73
+++ apr_functions.map 14 May 2004 07:40:31 -0000 1.74
@@ -156,9 +156,11 @@
MODULE=APR::Pool
-apr_pool_num_bytes | | p, recurse=0 #only available with -DAPR_POOL_DEBUG
apr_pool_cleanup_for_exec
- apr_pool_clear
+-apr_pool_clear
+mpxs_APR__Pool_clear
>apr_pool_clear_debug
- apr_pool_destroy
+-apr_pool_destroy
+ DEFINE_destroy | mpxs_apr_pool_DESTROY | SV *:obj
DEFINE_DESTROY | mpxs_apr_pool_DESTROY | SV *:obj
>apr_pool_destroy_debug
SV *:DEFINE_new | mpxs_apr_pool_create | SV *:parent_pool_obj
1.156 +19 -1 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.155
retrieving revision 1.156
diff -u -u -r1.155 -r1.156
--- FunctionTable.pm 10 May 2004 20:11:02 -0000 1.155
+++ FunctionTable.pm 14 May 2004 07:40:31 -0000 1.156
@@ -2,7 +2,7 @@
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# ! WARNING: generated by ModPerl::ParseSource/0.01
-# ! Mon May 10 13:02:13 2004
+# ! Thu May 13 22:34:11 2004
# ! do NOT edit, any changes will be lost !
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -5430,6 +5430,24 @@
{
'type' => 'apr_bucket *',
'name' => 'bucket'
+ }
+ ]
+ },
+ {
+ 'return_type' => 'void',
+ 'name' => 'mpxs_APR__Pool_clear',
+ 'attr' => [
+ 'static',
+ '__inline__'
+ ],
+ 'args' => [
+ {
+ 'type' => 'PerlInterpreter *',
+ 'name' => 'my_perl'
+ },
+ {
+ 'type' => 'SV *',
+ 'name' => 'obj'
}
]
},
