geoff 2003/09/09 10:22:39
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::DESTROY implemented
Reviewed by: stas
Revision Changes Path
1.5 +58 -7 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.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- pool.pm 5 Sep 2003 16:30:45 -0000 1.4
+++ pool.pm 9 Sep 2003 17:22:39 -0000 1.5
@@ -5,19 +5,28 @@
use Apache::Test;
+use Apache::RequestRec ();
use APR::Pool ();
+use APR::Table ();
use Apache::Const -compile => 'OK';
-sub cleanup {
+sub add_cleanup {
my $arg = shift;
- ok $arg == 33;
+ $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 => 4;
+ plan $r, tests => 13;
my $p = APR::Pool->new;
@@ -31,12 +40,54 @@
# my $num_bytes = $p->num_bytes;
# ok $num_bytes;
- $p->cleanup_register(\&cleanup, 33);
- $subp->cleanup_register(\&cleanup, 33);
+ $p->cleanup_register(\&add_cleanup, [$r, 'parent']);
+ $subp->cleanup_register(\&set_cleanup, [$r, 'child']);
- # should destroy the subpool too, so
- # cleanup is called twice
+ # should destroy the subpool too
$p->destroy;
+
+ my @notes = $r->notes->get('cleanup');
+ ok $notes[0] eq 'child';
+ ok $notes[1] eq 'parent';
+ ok @notes == 2;
+
+ # 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;
+
+ # DESTROY should be a no-op on native pools
+ my $p3 = $r->pool;
+ $p3->cleanup_register(\&set_cleanup, [$r, 'native DESTROY']);
+ $p3->DESTROY;
+
+ @notes = $r->notes->get('cleanup');
+ ok $notes[0] eq 'new DESTROY'; # same as before - no change
+ ok @notes == 1;
+
+ # make sure lexical scoping destroys the pool
+ {
+ my $p4 = APR::Pool->new;
+ $p4->cleanup_register(\&set_cleanup, [$r, 'new scoped']);
+ }
+
+ @notes = $r->notes->get('cleanup');
+ ok $notes[0] eq 'new scoped';
+ ok @notes == 1;
+
+ # but doesn't affect native pools
+ {
+ my $p5 = $r->pool;
+ $p5->cleanup_register(\&set_cleanup, [$r, 'native scoped']);
+ }
+
+ @notes = $r->notes->get('cleanup');
+ ok $notes[0] eq 'new scoped'; # same as before - no change
+ ok @notes == 1;
Apache::OK;
}
1.6 +49 -4 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.5
retrieving revision 1.6
diff -u -r1.5 -r1.6
--- APR__Pool.h 13 Jun 2002 02:59:05 -0000 1.5
+++ APR__Pool.h 9 Sep 2003 17:22:39 -0000 1.6
@@ -1,11 +1,22 @@
-#define apr_pool_DESTROY(p) apr_pool_destroy(p)
+#define MP_APR_POOL_NEW "APR::Pool::new"
+/**
+ * create a new pool or subpool
+ * @param 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)
{
apr_pool_t *parent = mpxs_sv_object_deref(obj, apr_pool_t);
- apr_pool_t *retval = NULL;
- (void)apr_pool_create(&retval, parent);
- return retval;
+ 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);
+
+ return newpool;
}
typedef struct {
@@ -18,6 +29,10 @@
#endif
} mpxs_cleanup_t;
+/**
+ * callback wrapper for Perl cleanup subroutines
+ * @param data internal storage
+ */
static apr_status_t mpxs_cleanup_run(void *data)
{
int count;
@@ -66,6 +81,12 @@
return status;
}
+/**
+ * run registered cleanups
+ * @param p pool with which to associate the cleanup
+ * @param cv subroutine reference to run
+ * @param arg optional argument to pass to the subroutine
+ */
static MP_INLINE void mpxs_apr_pool_cleanup_register(pTHX_ apr_pool_t *p,
SV *cv, SV *arg)
{
@@ -88,4 +109,28 @@
apr_pool_cleanup_register(p, data,
mpxs_cleanup_run,
apr_pool_cleanup_null);
+}
+
+/**
+ * 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;
+
+ /* 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);
+ }
}
1.58 +1 -0 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.57
retrieving revision 1.58
diff -u -r1.57 -r1.58
--- apr_functions.map 4 Sep 2003 16:39:44 -0000 1.57
+++ apr_functions.map 9 Sep 2003 17:22:39 -0000 1.58
@@ -155,6 +155,7 @@
apr_pool_clear
>apr_pool_clear_debug
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_create_ex
1.122 +14 -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.121
retrieving revision 1.122
diff -u -r1.121 -r1.122
--- FunctionTable.pm 30 Aug 2003 02:33:26 -0000 1.121
+++ FunctionTable.pm 9 Sep 2003 17:22:39 -0000 1.122
@@ -6429,6 +6429,20 @@
]
},
{
+ 'return_type' => 'void',
+ 'name' => 'mpxs_apr_pool_DESTROY',
+ 'attr' => [
+ 'static',
+ '__inline__'
+ ],
+ 'args' => [
+ {
+ 'type' => 'SV *',
+ 'name' => 'obj'
+ },
+ ]
+ },
+ {
'return_type' => 'apr_pool_t *',
'name' => 'mpxs_apr_pool_create',
'attr' => [
