perl-modperl-cvs mailing list archives

Site index · List index
Message view « Date » · « Thread »
Top « Date » · « Thread »
From s...@apache.org
Subject cvs commit: modperl-2.0/xs/tables/current/ModPerl FunctionTable.pm
Date Mon, 09 Feb 2004 19:32:43 GMT
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'
         }
       ]
     },
  
  
  

Mime
View raw message