stas 2004/02/09 11:32:43
Modified: . Changes
src/modules/perl modperl_callback.c modperl_filter.c
modperl_handler.c modperl_handler.h modperl_mgv.c
modperl_mgv.h modperl_types.h
t/filter both_str_req_add.t
t/filter/TestFilter both_str_req_add.pm
t/hooks push_handlers.t
t/hooks/TestHooks push_handlers.pm
todo release
xs/tables/current/ModPerl FunctionTable.pm
Log:
Anonymous subs are now supported in push_handlers, set_handlers,
add_input_filter, etc. A fast cached cv is used with non-ithreaded
perl. A slower deparse/eval approach (via B::Deparse) is used with
ithreads enabled perls. Further optimizations are planned for the
latter case.
Revision Changes Path
1.325 +6 -0 modperl-2.0/Changes
Index: Changes
===================================================================
RCS file: /home/cvs/modperl-2.0/Changes,v
retrieving revision 1.324
retrieving revision 1.325
diff -u -u -r1.324 -r1.325
--- Changes 9 Feb 2004 19:25:01 -0000 1.324
+++ Changes 9 Feb 2004 19:32:42 -0000 1.325
@@ -12,6 +12,12 @@
=item 1.99_13-dev
+Anonymous subs are now supported in push_handlers, set_handlers,
+add_input_filter, etc. A fast cached cv is used with non-ithreaded
+perl. A slower deparse/eval approach (via B::Deparse) is used with
+ithreads enabled perls. Further optimizations are planned for the
+latter case. [Stas]
+
ht_time w/o the pool is now available only via override/restore compat
API. format_time, has been renamed back to ht_time, and the default
values for fmt, time and gmt are now supported. [Stas]
1.68 +15 -1 modperl-2.0/src/modules/perl/modperl_callback.c
Index: modperl_callback.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_callback.c,v
retrieving revision 1.67
retrieving revision 1.68
diff -u -u -r1.67 -r1.68
--- modperl_callback.c 9 Feb 2004 19:09:34 -0000 1.67
+++ modperl_callback.c 9 Feb 2004 19:32:42 -0000 1.68
@@ -36,8 +36,22 @@
PUTBACK;
if (MpHandlerANON(handler)) {
- SV *sv = eval_pv(handler->name, TRUE); /* XXX: cache */
+#ifdef USE_ITHREADS
+ /* it's possible that the interpreter that is running the anon
+ * cv, isn't the one that compiled it. so to be safe need to
+ * re-eval the deparsed form before using it.
+ * XXX: possible optimizations, see modperl_handler_new_anon */
+ SV *sv = eval_pv(handler->name, TRUE);
cv = (CV*)SvRV(sv);
+#else
+ /* the same interpreter that has compiled the anon cv is used
+ * to run it */
+ if (!handler->cv) {
+ SV *sv = eval_pv(handler->name, TRUE);
+ handler->cv = (CV*)SvRV(sv); /* cache */
+ }
+ cv = handler->cv;
+#endif
}
else {
GV *gv = modperl_mgv_lookup_autoload(aTHX_ handler->mgv_cv, s, p);
1.81 +9 -12 modperl-2.0/src/modules/perl/modperl_filter.c
Index: modperl_filter.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_filter.c,v
retrieving revision 1.80
retrieving revision 1.81
diff -u -u -r1.80 -r1.81
--- modperl_filter.c 23 Dec 2003 15:56:01 -0000 1.80
+++ modperl_filter.c 9 Feb 2004 19:32:42 -0000 1.81
@@ -353,21 +353,19 @@
char *code = apr_pstrcat(p, "package ", package_name, ";",
init_handler_pv_code, NULL);
SV *sv = eval_pv(code, TRUE);
- char *init_handler_name;
/* fprintf(stderr, "code: %s\n", code); */
-
- if ((init_handler_name = modperl_mgv_name_from_sv(aTHX_ p, sv))) {
- modperl_handler_t *init_handler =
- modperl_handler_new(p, apr_pstrdup(p, init_handler_name));
+ modperl_handler_t *init_handler =
+ modperl_handler_new_from_sv(aTHX_ p, sv);
+ if (init_handler) {
MP_TRACE_h(MP_FUNC, "found init handler %s\n",
- init_handler->name);
+ modperl_handler_name(init_handler));
- if (! init_handler->attrs & MP_FILTER_INIT_HANDLER) {
+ if (!init_handler->attrs & MP_FILTER_INIT_HANDLER) {
Perl_croak(aTHX_ "handler %s doesn't have "
"the FilterInitHandler attribute set",
- init_handler->name);
+ modperl_handler_name(init_handler));
}
handler->next = init_handler;
@@ -1091,12 +1089,11 @@
SV *callback, const char *type)
{
apr_pool_t *pool = r ? r->pool : c->pool;
- char *handler_name;
+ modperl_handler_t *handler =
+ modperl_handler_new_from_sv(aTHX_ pool, callback);
- if ((handler_name = modperl_mgv_name_from_sv(aTHX_ pool, callback))) {
+ if (handler) {
ap_filter_t *f;
- modperl_handler_t *handler =
- modperl_handler_new(pool, apr_pstrdup(pool, handler_name));
modperl_filter_ctx_t *ctx =
(modperl_filter_ctx_t *)apr_pcalloc(pool, sizeof(*ctx));
1.21 +143 -4 modperl-2.0/src/modules/perl/modperl_handler.c
Index: modperl_handler.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_handler.c,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -u -r1.20 -r1.21
--- modperl_handler.c 9 Feb 2004 18:19:09 -0000 1.20
+++ modperl_handler.c 9 Feb 2004 19:32:42 -0000 1.21
@@ -1,5 +1,64 @@
#include "mod_perl.h"
+
+static
+char *modperl_coderef2text(pTHX_ apr_pool_t *p, CV *cv)
+{
+ dSP;
+ int count;
+ SV *bdeparse;
+ char *text;
+
+ /* B::Deparse >= 0.61 needed for blessed code references */
+
+ load_module(PERL_LOADMOD_NOIMPORT,
+ newSVpvn("B::Deparse", 10),
+ newSVnv(0.61));
+
+ ENTER;
+ SAVETMPS;
+
+ /* create the B::Deparse object */
+ PUSHMARK(sp);
+ XPUSHs(sv_2mortal(newSVpvn("B::Deparse", 10)));
+ PUTBACK;
+ count = call_method("new", G_SCALAR);
+ SPAGAIN;
+ if (count != 1) {
+ Perl_croak(aTHX_ "Unexpected return value from B::Deparse::new\n");
+ }
+ if (SvTRUE(ERRSV)) {
+ Perl_croak(aTHX_ "error: %s", SvPVX(ERRSV));
+ }
+ bdeparse = POPs;
+
+ PUSHMARK(sp);
+ XPUSHs(bdeparse);
+ XPUSHs(sv_2mortal(newRV_inc((SV*)cv)));
+ PUTBACK;
+ count = call_method("coderef2text", G_SCALAR);
+ SPAGAIN;
+ if (count != 1) {
+ Perl_croak(aTHX_ "Unexpected return value from "
+ "B::Deparse::coderef2text\n");
+ }
+ if (SvTRUE(ERRSV)) {
+ Perl_croak(aTHX_ "error: %s", SvPVX(ERRSV));
+ }
+
+ {
+ STRLEN n_a;
+ text = POPpx;
+ }
+
+ PUTBACK;
+
+ FREETMPS;
+ LEAVE;
+
+ return apr_pstrcat(p, "sub ", text, NULL);
+}
+
modperl_handler_t *modperl_handler_new(apr_pool_t *p, const char *name)
{
modperl_handler_t *handler =
@@ -20,6 +79,7 @@
break;
}
+ handler->cv = NULL;
handler->name = name;
MP_TRACE_h(MP_FUNC, "[%s] new handler %s\n",
modperl_pid_tid(p), handler->name);
@@ -27,6 +87,60 @@
return handler;
}
+
+static
+modperl_handler_t *modperl_handler_new_anon(pTHX_ apr_pool_t *p, CV *cv)
+{
+ modperl_handler_t *handler =
+ (modperl_handler_t *)apr_pcalloc(p, sizeof(*handler));
+ MpHandlerPARSED_On(handler);
+ MpHandlerANON_On(handler);
+
+#ifdef USE_ITHREADS
+ /* XXX: perhaps we can optimize this further. At the moment when
+ * perl w/ ithreads is used, we always deparse the anon subs
+ * before storing them and then eval them each time they are
+ * used. This is because we don't know whether the same perl that
+ * compiled the anonymous sub is used to run it.
+ *
+ * A possible optimization is to cache the CV and use that cached
+ * value w/ or w/o deparsing at all if:
+ *
+ * - the mpm is non-threaded mpm and no +Clone/+Parent is used
+ * (i.e. no perl pools) (no deparsing is needed at all)
+ *
+ * - the interpreter that has supplied the anon cv is the same
+ * interpreter that is executing that cv (requires storing aTHX
+ * in the handler's struct) (need to deparse in case the
+ * interpreter gets switched)
+ *
+ * - other cases?
+ */
+ handler->cv = NULL;
+ handler->name = modperl_coderef2text(aTHX_ p, cv);
+ MP_TRACE_h(MP_FUNC, "[%s] new deparsed anon handler:\n%s\n",
+ modperl_pid_tid(p), handler->name);
+#else
+ /* it's safe to cache and later use the cv, since the same perl
+ * interpeter is always used */
+ handler->cv = cv;
+ handler->name = NULL;
+ MP_TRACE_h(MP_FUNC, "[%s] new cached cv anon handler\n",
+ modperl_pid_tid(p));
+#endif
+
+ return handler;
+}
+
+MP_INLINE
+const char *modperl_handler_name(modperl_handler_t *handler)
+{
+ /* a handler containing an anonymous sub doesn't have a normal sub
+ * name */
+ return handler->name ? handler->name : "anonymous sub";
+}
+
+
int modperl_handler_resolve(pTHX_ modperl_handler_t **handp,
apr_pool_t *p, server_rec *s)
{
@@ -320,14 +434,39 @@
action, NULL);
}
+modperl_handler_t *modperl_handler_new_from_sv(pTHX_ apr_pool_t *p, SV *sv)
+{
+ char *name = NULL;
+ GV *gv;
+
+ if (SvROK(sv)) {
+ sv = SvRV(sv);
+ }
+
+ switch (SvTYPE(sv)) {
+ case SVt_PV:
+ name = SvPVX(sv);
+ return modperl_handler_new(p, apr_pstrdup(p, name));
+ break;
+ case SVt_PVCV:
+ if (CvANON((CV*)sv)) {
+ return modperl_handler_new_anon(aTHX_ p, (CV*)sv);
+ }
+ gv = CvGV((CV*)sv);
+ name = apr_pstrcat(p, HvNAME(GvSTASH(gv)), "::", GvNAME(gv), NULL);
+ return modperl_handler_new(p, apr_pstrdup(p, name));
+ break;
+ };
+
+ return NULL;
+}
+
int modperl_handler_push_handlers(pTHX_ apr_pool_t *p,
MpAV *handlers, SV *sv)
{
- char *handler_name;
+ modperl_handler_t *handler = modperl_handler_new_from_sv(aTHX_ p, sv);
- if ((handler_name = modperl_mgv_name_from_sv(aTHX_ p, sv))) {
- modperl_handler_t *handler =
- modperl_handler_new(p, apr_pstrdup(p, handler_name));
+ if (handler) {
modperl_handler_array_push(handlers, handler);
return TRUE;
}
1.9 +4 -0 modperl-2.0/src/modules/perl/modperl_handler.h
Index: modperl_handler.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_handler.h,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -u -r1.8 -r1.9
--- modperl_handler.h 19 Oct 2001 16:40:44 -0000 1.8
+++ modperl_handler.h 9 Feb 2004 19:32:42 -0000 1.9
@@ -21,6 +21,10 @@
modperl_handler_t *modperl_handler_new(apr_pool_t *p, const char *name);
+modperl_handler_t *modperl_handler_new_from_sv(pTHX_ apr_pool_t *p, SV *sv);
+
+MP_INLINE const char *modperl_handler_name(modperl_handler_t *handler);
+
int modperl_handler_resolve(pTHX_ modperl_handler_t **handp,
apr_pool_t *p, server_rec *s);
1.32 +0 -25 modperl-2.0/src/modules/perl/modperl_mgv.c
Index: modperl_mgv.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_mgv.c,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -u -r1.31 -r1.32
--- modperl_mgv.c 9 Feb 2004 18:51:07 -0000 1.31
+++ modperl_mgv.c 9 Feb 2004 19:32:42 -0000 1.32
@@ -84,31 +84,6 @@
return symbol;
}
-char *modperl_mgv_name_from_sv(pTHX_ apr_pool_t *p, SV *sv)
-{
- char *name = NULL;
- GV *gv;
-
- if (SvROK(sv)) {
- sv = SvRV(sv);
- }
-
- switch (SvTYPE(sv)) {
- case SVt_PV:
- name = SvPVX(sv);
- break;
- case SVt_PVCV:
- if (CvANON((CV*)sv)) {
- Perl_croak(aTHX_ "anonymous handlers not (yet) supported");
- }
- gv = CvGV((CV*)sv);
- name = apr_pstrcat(p, HvNAME(GvSTASH(gv)), "::", GvNAME(gv), NULL);
- break;
- };
-
- return name;
-}
-
void modperl_mgv_append(pTHX_ apr_pool_t *p, modperl_mgv_t *symbol,
const char *name)
{
1.7 +0 -2 modperl-2.0/src/modules/perl/modperl_mgv.h
Index: modperl_mgv.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_mgv.h,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -u -r1.6 -r1.7
--- modperl_mgv.h 6 Dec 2002 07:58:22 -0000 1.6
+++ modperl_mgv.h 9 Feb 2004 19:32:42 -0000 1.7
@@ -8,8 +8,6 @@
modperl_mgv_t *modperl_mgv_compile(pTHX_ apr_pool_t *p, const char *name);
-char *modperl_mgv_name_from_sv(pTHX_ apr_pool_t *p, SV *sv);
-
GV *modperl_mgv_lookup(pTHX_ modperl_mgv_t *symbol);
GV *modperl_mgv_lookup_autoload(pTHX_ modperl_mgv_t *symbol,
1.71 +1 -0 modperl-2.0/src/modules/perl/modperl_types.h
Index: modperl_types.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_types.h,v
retrieving revision 1.70
retrieving revision 1.71
diff -u -u -r1.70 -r1.71
--- modperl_types.h 13 Dec 2003 23:40:31 -0000 1.70
+++ modperl_types.h 9 Feb 2004 19:32:42 -0000 1.71
@@ -164,6 +164,7 @@
modperl_mgv_t *mgv_obj;
modperl_mgv_t *mgv_cv;
const char *name; /* original name from .conf if any */
+ CV *cv;
U8 flags;
U32 attrs;
modperl_handler_t *next;
1.3 +1 -0 modperl-2.0/t/filter/both_str_req_add.t
Index: both_str_req_add.t
===================================================================
RCS file: /home/cvs/modperl-2.0/t/filter/both_str_req_add.t,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -u -r1.2 -r1.3
--- both_str_req_add.t 18 Apr 2003 06:18:56 -0000 1.2
+++ both_str_req_add.t 9 Feb 2004 19:32:42 -0000 1.3
@@ -10,6 +10,7 @@
my $data = join ' ', 'A'..'Z', 0..9;
my $expected = lc $data; # that's what the input filter does
$expected =~ s/\s+//g; # that's what the output filter does
+$expected .= "end"; # that's what the anon output filter does
my $location = '/TestFilter__both_str_req_add';
my $response = POST_BODY $location, content => $data;
ok t_cmp($expected, $response, "lc input and reverse output filters");
1.4 +12 -0 modperl-2.0/t/filter/TestFilter/both_str_req_add.pm
Index: both_str_req_add.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/filter/TestFilter/both_str_req_add.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -u -r1.3 -r1.4
--- both_str_req_add.pm 18 Sep 2003 08:09:06 -0000 1.3
+++ both_str_req_add.pm 9 Feb 2004 19:32:42 -0000 1.4
@@ -20,6 +20,18 @@
# test adding by sub's name
$r->add_output_filter("out_filter");
+ # test adding anon sub
+ $r->add_output_filter(sub {
+ my $filter = shift;
+
+ while ($filter->read(my $buffer, 1024)) {
+ $buffer .= "end";
+ $filter->print($buffer);
+ }
+
+ return Apache::OK;
+ });
+
return Apache::DECLINED;
}
1.4 +1 -4 modperl-2.0/t/hooks/push_handlers.t
Index: push_handlers.t
===================================================================
RCS file: /home/cvs/modperl-2.0/t/hooks/push_handlers.t,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -u -r1.3 -r1.4
--- push_handlers.t 18 Apr 2003 06:18:57 -0000 1.3
+++ push_handlers.t 9 Feb 2004 19:32:43 -0000 1.4
@@ -11,10 +11,7 @@
full_coderef coderef1 coderef2 coderef3);
my @anon = qw(anonymous anonymous1 coderef4 anonymous3);
-my @strings = @refs;
-
-# XXX: anon-handlers unsupported yet
-# push @strings, @anon
+my @strings = (@refs, @anon);
my $location = "/TestHooks__push_handlers";
my $expected = join "\n", @strings, '';
1.7 +8 -9 modperl-2.0/t/hooks/TestHooks/push_handlers.pm
Index: push_handlers.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/hooks/TestHooks/push_handlers.pm,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -u -r1.6 -r1.7
--- push_handlers.pm 11 Aug 2003 20:34:22 -0000 1.6
+++ push_handlers.pm 9 Feb 2004 19:32:43 -0000 1.7
@@ -21,17 +21,16 @@
\&TestHooks::push_handlers::full_coderef);
$r->push_handlers(PerlResponseHandler =>
- [\&coderef1, \&coderef2, \&coderef3]);
+ [\&coderef1, __PACKAGE__.'::coderef2', \&coderef3]);
-# XXX: anon-handlers unsupported yet
-# $r->push_handlers(PerlResponseHandler =>
-# sub { return say(shift, "anonymous") });
+ $r->push_handlers(PerlResponseHandler =>
+ sub { return say(shift, "anonymous") });
-# $r->push_handlers(PerlResponseHandler =>
-# [sub { return say(shift, "anonymous1") },
-# \&coderef4,
-# sub { return say(shift, "anonymous3") },
-# ]);
+ $r->push_handlers(PerlResponseHandler =>
+ [sub { return say(shift, "anonymous1") },
+ \&coderef4,
+ sub { return say(shift, "anonymous3") },
+ ]);
$r->push_handlers(PerlResponseHandler => \&end);
1.15 +0 -5 modperl-2.0/todo/release
Index: release
===================================================================
RCS file: /home/cvs/modperl-2.0/todo/release,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -u -r1.14 -r1.15
--- release 9 Feb 2004 19:25:01 -0000 1.14
+++ release 9 Feb 2004 19:32:43 -0000 1.15
@@ -45,9 +45,6 @@
the whole thread is here:
http://marc.theaimsgroup.com/?t=103713532800003&r=1&w=2
-- anonymous handler (for push_handlers, add_input_filter, etc), see
- modperl_mgv.c: modperl_mgv_name_from_sv
-
- PerlModule, PerlRequire, Perl{Set,Add}Var in .htaccess is missing
Owner: geoff
@@ -105,5 +102,3 @@
* Apache->unescape_url{_info}:
not yet implemented. should be moved to Apache::Util
-
-
1.145 +12 -2 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.144
retrieving revision 1.145
diff -u -u -r1.144 -r1.145
--- FunctionTable.pm 9 Feb 2004 19:05:59 -0000 1.144
+++ FunctionTable.pm 9 Feb 2004 19:32:43 -0000 1.145
@@ -3197,8 +3197,8 @@
]
},
{
- 'return_type' => 'char *',
- 'name' => 'modperl_mgv_name_from_sv',
+ 'return_type' => 'modperl_handler_t *',
+ 'name' => 'modperl_handler_new_from_sv',
'args' => [
{
'type' => 'PerlInterpreter *',
@@ -3211,6 +3211,16 @@
{
'type' => 'SV *',
'name' => 'sv'
+ }
+ ]
+ },
+ {
+ 'return_type' => 'const char *',
+ 'name' => 'modperl_handler_name',
+ 'args' => [
+ {
+ 'type' => 'modperl_handler_t *',
+ 'name' => 'handler'
}
]
},
