ok, here is a first pass on APR::Pool::DESTROY.
what basically happens here is that DESTROY only calls apr_pool_destroy if the object on which it is invoked contains magic. so
my $p = APR::Pool->new; $p->DESTROY;
calls apr_pool_destroy, while
my $p = $r->pool; $p->DESTROY;
does not. in either case
$p->destroy;
still works, destroying the pool with no checks whatsoever.
in order to add magic to APR::Pool->new() based objects, I had to pull a few tricks. to avoid messing with the existing typemaps (which wouldn't work anyway) and the majority of the autogeneration code, what I ended up doing was adding an additional parameter to apr_functions.map. the additional parameter, if present, represents a function to place in a CLEANUP section in WrapXS. this allows the current autogenerated code to keep on working, while allowing me to manipulate the object just before it is returned to perl-space. the result ends up looking like this after you follow the macros around
APR::Pool
mpxs_APR__Pool_new(obj)
SV * obj CODE:
RETVAL = mpxs_apr_pool_create(aTHX_ obj);
OUTPUT: RETVAL
CLEANUP: sv_magic(SvRV(ST(0)), Nullsv, '~', NULL, -1);
I used '~' because that's what modperl_filter uses, which I assumed was a single character for performance reasons. we can always use something else, but I didn't think using identical flags would collide in this instance.
anyway, attached is the patch in full. as I said, it's only a first pass, but it seems to work and is relatively clean. adding the ability to set CLEANUP sections may be geniuinely useful if we need to do stuff like this in the future, so I thought it was as good an approach as any.
--Geoff
Index: lib/ModPerl/FunctionMap.pm
===================================================================
RCS file: /home/cvspublic/modperl-2.0/lib/ModPerl/FunctionMap.pm,v
retrieving revision 1.10
diff -u -r1.10 FunctionMap.pm
--- lib/ModPerl/FunctionMap.pm 26 May 2002 23:39:32 -0000 1.10
+++ lib/ModPerl/FunctionMap.pm 8 Sep 2003 19:06:30 -0000
@@ -111,7 +111,7 @@
next;
}
- my($name, $dispatch, $argspec, $alias) = split /\s*\|\s*/;
+ my($name, $dispatch, $argspec, $alias, $cleanup) = split /\s*\|\s*/;
my $return_type;
if ($name =~ s/^([^:]+)://) {
@@ -153,6 +153,7 @@
argspec => $argspec ? [split /\s*,\s*/, $argspec] : "",
return_type => $return_type,
alias => $alias,
+ cleanup => $cleanup,
};
for (keys %cur) {
Index: lib/ModPerl/TypeMap.pm
===================================================================
RCS file: /home/cvspublic/modperl-2.0/lib/ModPerl/TypeMap.pm,v
retrieving revision 1.18
diff -u -r1.18 TypeMap.pm
--- lib/ModPerl/TypeMap.pm 30 Dec 2002 00:27:13 -0000 1.18
+++ lib/ModPerl/TypeMap.pm 8 Sep 2003 19:06:30 -0000
@@ -251,7 +251,7 @@
thx => $func->{thx},
};
- for (qw(dispatch argspec orig_args prefix)) {
+ for (qw(dispatch argspec orig_args prefix cleanup)) {
$mf->{$_} = $map->{$_};
}
Index: lib/ModPerl/WrapXS.pm
===================================================================
RCS file: /home/cvspublic/modperl-2.0/lib/ModPerl/WrapXS.pm,v
retrieving revision 1.61
diff -u -r1.61 WrapXS.pm
--- lib/ModPerl/WrapXS.pm 30 Aug 2003 02:33:26 -0000 1.61
+++ lib/ModPerl/WrapXS.pm 8 Sep 2003 19:06:30 -0000
@@ -60,11 +60,12 @@
for my $entry (@{ $self->function_list() }) {
my $func = $typemap->map_function($entry);
+
#print "FAILED to map $entry->{name}\n" unless $func;
next unless $func;
- my($name, $module, $class, $args) =
- @{ $func } { qw(perl_name module class args) };
+ my($name, $module, $class, $args, $cleanup) =
+ @{ $func } { qw(perl_name module class args cleanup) };
$self->{XS}->{ $module } ||= [];
@@ -147,6 +148,18 @@
$retval->[1]
EOF
+
+ if ($cleanup) {
+ # CLEANUP XS section
+ # eg, mpxs_apr_pool_create magic
+
+ $code .= <<EOF
+ CLEANUP:
+ $cleanup;
+
+EOF
+
+ }
}
$func->{code} = $code;
Index: t/response/TestAPR/pool.pm
===================================================================
RCS file: /home/cvspublic/modperl-2.0/t/response/TestAPR/pool.pm,v
retrieving revision 1.4
diff -u -r1.4 pool.pm
--- t/response/TestAPR/pool.pm 5 Sep 2003 16:30:45 -0000 1.4
+++ t/response/TestAPR/pool.pm 8 Sep 2003 19:06:30 -0000
@@ -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;
}
Index: xs/modperl_xs_util.h
===================================================================
RCS file: /home/cvspublic/modperl-2.0/xs/modperl_xs_util.h,v
retrieving revision 1.17
diff -u -r1.17 modperl_xs_util.h
--- xs/modperl_xs_util.h 22 Aug 2003 05:26:12 -0000 1.17
+++ xs/modperl_xs_util.h 8 Sep 2003 19:06:30 -0000
@@ -94,4 +94,6 @@
MARK++; \
}
+#define mpxs_pool_mg_set sv_magic(SvRV(ST(0)), Nullsv, '~', NULL, -1);
+
#endif /* MODPERL_XS_H */
Index: xs/APR/Pool/APR__Pool.h
===================================================================
RCS file: /home/cvspublic/modperl-2.0/xs/APR/Pool/APR__Pool.h,v
retrieving revision 1.5
diff -u -r1.5 APR__Pool.h
--- xs/APR/Pool/APR__Pool.h 13 Jun 2002 02:59:05 -0000 1.5
+++ xs/APR/Pool/APR__Pool.h 8 Sep 2003 19:06:30 -0000
@@ -1,5 +1,3 @@
-#define apr_pool_DESTROY(p) apr_pool_destroy(p)
-
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);
@@ -88,4 +86,17 @@
apr_pool_cleanup_register(p, data,
mpxs_cleanup_run,
apr_pool_cleanup_null);
+}
+
+static MP_INLINE void mpxs_apr_pool_DESTROY(pTHX_ SV *p) {
+
+ MAGIC *mg;
+
+ /* APR::Pool::DESTROY
+ * we only want to DESTROY object created by
+ * APR::Pool->new */
+
+ if ((mg = mg_find(SvRV(p), '~'))) {
+ apr_pool_destroy(mpxs_sv_object_deref(p, apr_pool_t));
+ }
}
Index: xs/maps/apr_functions.map
===================================================================
RCS file: /home/cvspublic/modperl-2.0/xs/maps/apr_functions.map,v
retrieving revision 1.57
diff -u -r1.57 apr_functions.map
--- xs/maps/apr_functions.map 4 Sep 2003 16:39:44 -0000 1.57
+++ xs/maps/apr_functions.map 8 Sep 2003 19:06:30 -0000
@@ -155,8 +155,9 @@
apr_pool_clear
>apr_pool_clear_debug
apr_pool_destroy
+ void:DEFINE_DESTROY | mpxs_apr_pool_DESTROY | SV *:p
>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 *:obj | | mpxs_pool_mg_set
-apr_pool_create_ex
>apr_pool_create_ex_debug
!apr_pool_userdata_get
Index: xs/tables/current/ModPerl/FunctionTable.pm
===================================================================
RCS file: /home/cvspublic/modperl-2.0/xs/tables/current/ModPerl/FunctionTable.pm,v
retrieving revision 1.121
diff -u -r1.121 FunctionTable.pm
--- xs/tables/current/ModPerl/FunctionTable.pm 30 Aug 2003 02:33:26 -0000 1.121
+++ xs/tables/current/ModPerl/FunctionTable.pm 8 Sep 2003 19:06:30 -0000
@@ -6429,6 +6429,20 @@
]
},
{
+ 'return_type' => 'void',
+ 'name' => 'mpxs_apr_pool_DESTROY',
+ 'attr' => [
+ 'static',
+ '__inline__'
+ ],
+ 'args' => [
+ {
+ 'type' => 'SV *',
+ 'name' => 'p'
+ },
+ ]
+ },
+ {
'return_type' => 'apr_pool_t *',
'name' => 'mpxs_apr_pool_create',
'attr' => [--------------------------------------------------------------------- To unsubscribe, e-mail: [EMAIL PROTECTED] For additional commands, e-mail: [EMAIL PROTECTED]
