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/todo release
Date Fri, 02 Apr 2004 02:17:47 GMT
stas        2004/04/01 18:17:46

  Modified:    ModPerl-Registry/lib/ModPerl RegistryCooker.pm
               ModPerl-Registry/t perlrun_extload.t special_blocks.t
               ModPerl-Registry/t/cgi-bin perlrun_decl.pm
                        perlrun_extload.pl perlrun_nondecl.pl
                        special_blocks.pl
               ModPerl-Registry/t/conf modperl_extra_startup.pl
               src/modules/perl mod_perl.c modperl_handler.c modperl_perl.c
                        modperl_perl.h modperl_perl_global.c
                        modperl_perl_global.h modperl_util.c modperl_util.h
               t/response/TestModperl endav.pm
               xs/ModPerl/Global ModPerl__Global.h
               xs/maps  modperl_functions.map
               xs/tables/current/ModPerl FunctionTable.pm
               .        Changes
               todo     release
  Log:
  'SetHandler perl-script' no longer grabs any newly encountered END
  blocks, and removes them from PL_endav, but only if they are
  explicitly registered via ModPerl::Global::special_list_register(END
  => $package_name) (this is a new function). It's now possible to have
  a complete control of when END blocks are run from the user space, not
  only in the registry handlers [Stas]
  
  END blocks encountered by child processes and not hijacked by
  ModPerl::Global::special_list_register() are now executed at the
  server shutdown (previously they weren't executed at all). [Stas]
  
  and a few other assorted re-shufflings, too intervowen to commit
  separately
  
  Revision  Changes    Path
  1.46      +2 -1      modperl-2.0/ModPerl-Registry/lib/ModPerl/RegistryCooker.pm
  
  Index: RegistryCooker.pm
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/ModPerl-Registry/lib/ModPerl/RegistryCooker.pm,v
  retrieving revision 1.45
  retrieving revision 1.46
  diff -u -u -r1.45 -r1.46
  --- RegistryCooker.pm	10 Mar 2004 23:19:44 -0000	1.45
  +++ RegistryCooker.pm	2 Apr 2004 02:17:45 -0000	1.46
  @@ -690,7 +690,8 @@
   
       $self->debug("compiling $self->{FILENAME}") if DEBUG && D_COMPILE;
   
  -    ModPerl::Global::special_list_clear(END => $self->{PACKAGE});
  +    ModPerl::Global::special_list_register(END => $self->{PACKAGE});
  +    ModPerl::Global::special_list_clear(   END => $self->{PACKAGE});
   
       {
           # let the code define its own warn and strict level 
  
  
  
  1.2       +1 -1      modperl-2.0/ModPerl-Registry/t/perlrun_extload.t
  
  Index: perlrun_extload.t
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/ModPerl-Registry/t/perlrun_extload.t,v
  retrieving revision 1.1
  retrieving revision 1.2
  diff -u -u -r1.1 -r1.2
  --- perlrun_extload.t	9 Mar 2004 06:35:34 -0000	1.1
  +++ perlrun_extload.t	2 Apr 2004 02:17:45 -0000	1.2
  @@ -15,7 +15,7 @@
       my $res = get_body($same_interp, $url);
       skip_not_same_interp(
           !defined($res),
  -        "01234",
  +        "d1nd1234",
           $res,
           "PerlRun requiring an external lib with subs",
       );
  
  
  
  1.9       +3 -0      modperl-2.0/ModPerl-Registry/t/special_blocks.t
  
  Index: special_blocks.t
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/ModPerl-Registry/t/special_blocks.t,v
  retrieving revision 1.8
  retrieving revision 1.9
  diff -u -u -r1.8 -r1.9
  --- special_blocks.t	22 Nov 2003 07:38:48 -0000	1.8
  +++ special_blocks.t	2 Apr 2004 02:17:45 -0000	1.9
  @@ -20,6 +20,9 @@
   {
       # PerlRun always run BEGIN/END since it's never cached
   
  +    # see also t/perlrun_extload.t which exercises BEGIN/END blocks
  +    # from external modules loaded from PerlRun scripts
  +
       my $alias = "perlrun";
       my $url = "/same_interp/$alias/special_blocks.pl";
       my $same_interp = Apache::TestRequest::same_interp_tie($url);
  
  
  
  1.2       +13 -1     modperl-2.0/ModPerl-Registry/t/cgi-bin/perlrun_decl.pm
  
  Index: perlrun_decl.pm
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/ModPerl-Registry/t/cgi-bin/perlrun_decl.pm,v
  retrieving revision 1.1
  retrieving revision 1.2
  diff -u -u -r1.1 -r1.2
  --- perlrun_decl.pm	9 Mar 2004 06:35:34 -0000	1.1
  +++ perlrun_decl.pm	2 Apr 2004 02:17:45 -0000	1.2
  @@ -6,6 +6,18 @@
   use base qw(Exporter);
   our @EXPORT = qw(decl_proto);
   
  -sub decl_proto ($;$) { my $x = shift; $x*"0"; }
  +# this BEGIN block is called only once, since this module doesn't get
  +# removed from %INC after it was loaded
  +BEGIN {
  +    # use an external package which will persist across requests
  +    $MyData::blocks{perlrun_decl}++;
  +}
  +
  +sub decl_proto ($;$) { shift }
  +
  +# this END block won't be executed until the server shutdown
  +END {
  +    $MyData::blocks{perlrun_decl}--;
  +}
   
   1;
  
  
  
  1.3       +50 -27    modperl-2.0/ModPerl-Registry/t/cgi-bin/perlrun_extload.pl
  
  Index: perlrun_extload.pl
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/ModPerl-Registry/t/cgi-bin/perlrun_extload.pl,v
  retrieving revision 1.2
  retrieving revision 1.3
  diff -u -u -r1.2 -r1.3
  --- perlrun_extload.pl	9 Mar 2004 06:54:14 -0000	1.2
  +++ perlrun_extload.pl	2 Apr 2004 02:17:45 -0000	1.3
  @@ -6,33 +6,56 @@
   use File::Spec::Functions qw(catfile catdir);
   
   use lib catdir Apache::Test::vars('serverroot'), 'cgi-bin';
  -my $require = catfile Apache::Test::vars('serverroot'), 'cgi-bin', 
  -    'perlrun_nondecl.pl';
  -
  -# require a module w/ package declaration (it doesn't get reloaded
  -# because it declares the package). But we still have a problem with
  -# subs declaring prototypes. When perlrun_decl->import is called, the
  -# original function's prototype doesn't match the aliases prototype.
  -# see decl_proto()
  -BEGIN { t_server_log_warn_is_expected() if perlrun_decl->can("decl_proto"); }
  -use perlrun_decl;
  -
  -# require a lib w/o package declaration. Functions in that lib get
  -# automatically aliased to the functions in the current package.
  -require "$require";
  +my $require = catfile Apache::Test::vars('serverroot'),
  +    qw(cgi-bin perlrun_nondecl.pl);
   
   print "Content-type: text/plain\n\n";
   
  -### declared package module
  -print decl_proto(0);
  -
  -### non-declared package module
  -# they all get redefined warning inside perlrun_nondecl.pl, since that
  -# lib loads it into main::, vs. PerlRun undefs the current __PACKAGE__
  -print nondecl_no_proto();
  -print nondecl_proto(2);
  -print nondecl_proto_empty("whatever");
  -print nondecl_const();
  -
  -
  -
  +### declared package module ###
  +{
  +    # require a module w/ package declaration (it doesn't get reloaded
  +    # because it declares the package). But we still have a problem with
  +    # subs declaring prototypes. When perlrun_decl->import is called, the
  +    # original function's prototype doesn't match the aliases prototype.
  +    # see decl_proto()
  +    BEGIN { t_server_log_warn_is_expected()
  +                if perlrun_decl->can("decl_proto"); 
  +    }
  +    use perlrun_decl;
  +
  +    die "perlrun_decl BEGIN block was run more than once"
  +        if $MyData::blocks{perlrun_decl} > 1;
  +
  +    print "d";
  +    print decl_proto(1);
  +}
  +
  +### non-declared package module ###
  +{
  +    # how many times were were called from the same interpreter
  +    $MyData::blocks{cycle}{perlrun_nondecl}++;
  +    $MyData::blocks{BEGIN}{perlrun_nondecl} ||= 0;
  +    $MyData::blocks{END}  {perlrun_nondecl} ||= 0;
  +
  +    # require a lib w/o package declaration. Functions in that lib get
  +    # automatically aliased to the functions in the current package.
  +    require "$require";
  +
  +    die "perlrun_nondecl's BEGIN block wasn't run"
  +        if $MyData::blocks{BEGIN}{perlrun_nondecl} !=
  +           $MyData::blocks{cycle}{perlrun_nondecl};
  +
  +    # the END block for this cycle didn't run yet, but we can test the
  +    # previous cycle's one
  +    die "perlrun_nondecl's END block wasn't run"
  +        if $MyData::blocks{END}{perlrun_nondecl} + 1 !=
  +           $MyData::blocks{cycle}{perlrun_nondecl};
  +
  +    # they all get redefined warning inside perlrun_nondecl.pl, since that
  +    # lib loads it into main::, vs. PerlRun undefs the current __PACKAGE__
  +    print "nd";
  +    print nondecl_no_proto();
  +    print nondecl_proto(2);
  +    print nondecl_proto_empty("whatever");
  +    print nondecl_const();
  +}
  
  
  
  1.2       +11 -2     modperl-2.0/ModPerl-Registry/t/cgi-bin/perlrun_nondecl.pl
  
  Index: perlrun_nondecl.pl
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/ModPerl-Registry/t/cgi-bin/perlrun_nondecl.pl,v
  retrieving revision 1.1
  retrieving revision 1.2
  diff -u -u -r1.1 -r1.2
  --- perlrun_nondecl.pl	9 Mar 2004 06:35:34 -0000	1.1
  +++ perlrun_nondecl.pl	2 Apr 2004 02:17:45 -0000	1.2
  @@ -5,9 +5,16 @@
   
   my $num;
   
  +# this BEGIN block is called on every request, since this file gets
  +# removed from %INC after it was loaded
  +BEGIN {
  +    # use an external package which will persist across requests
  +    $MyData::blocks{BEGIN}{perlrun_nondecl}++;
  +}
  +
   use subs qw(warn_exp);
   
  -# all subs in tis file get 'redefined' warning because they are
  +# all subs in this file get 'redefined' warning because they are
   # reloaded in the main:: package, which is not under PerlRun's
   # control.
   
  @@ -41,6 +48,8 @@
   # a constant.
   sub nondecl_const       ()  { 4 }
   
  -
  +END {
  +    $MyData::blocks{END}{perlrun_nondecl}++;
  +}
   
   1;
  
  
  
  1.6       +1 -1      modperl-2.0/ModPerl-Registry/t/cgi-bin/special_blocks.pl
  
  Index: special_blocks.pl
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/ModPerl-Registry/t/cgi-bin/special_blocks.pl,v
  retrieving revision 1.5
  retrieving revision 1.6
  diff -u -u -r1.5 -r1.6
  --- special_blocks.pl	16 Aug 2002 10:11:39 -0000	1.5
  +++ special_blocks.pl	2 Apr 2004 02:17:45 -0000	1.6
  @@ -1,6 +1,7 @@
   #!perl -w
   
   # test BEGIN/END blocks
  +
   use Apache::RequestRec ();
   
   use vars qw($query);
  @@ -31,4 +32,3 @@
           print "end ok";
       }
   }
  -
  
  
  
  1.15      +1 -1      modperl-2.0/ModPerl-Registry/t/conf/modperl_extra_startup.pl
  
  Index: modperl_extra_startup.pl
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/ModPerl-Registry/t/conf/modperl_extra_startup.pl,v
  retrieving revision 1.14
  retrieving revision 1.15
  diff -u -u -r1.14 -r1.15
  --- modperl_extra_startup.pl	19 Jan 2004 19:59:58 -0000	1.14
  +++ modperl_extra_startup.pl	2 Apr 2004 02:17:45 -0000	1.15
  @@ -35,7 +35,7 @@
       );
   
       my @preload = qw(basic.pl env.pl require.pl special_blocks.pl
  -        redirect.pl 206.pl content_type.pl);
  +                     redirect.pl 206.pl content_type.pl);
   
       for my $file (@preload) {
           $rl->handler("/registry_bb/$file");
  
  
  
  1.212     +27 -3     modperl-2.0/src/modules/perl/mod_perl.c
  
  Index: mod_perl.c
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/src/modules/perl/mod_perl.c,v
  retrieving revision 1.211
  retrieving revision 1.212
  diff -u -u -r1.211 -r1.212
  --- mod_perl.c	4 Mar 2004 06:01:06 -0000	1.211
  +++ mod_perl.c	2 Apr 2004 02:17:45 -0000	1.212
  @@ -645,13 +645,26 @@
       return modperl_destruct_level;
   }
   
  +#ifdef USE_ITHREADS
  +
  +static apr_status_t
  +modperl_perl_call_endav_mip(pTHX_ modperl_interp_pool_t *mip,
  +                            void *data)
  +{
  +    modperl_perl_call_endav(aTHX);
  +    return APR_SUCCESS;
  +}
  +
  +#endif /* USE_ITHREADS */
  +
   static apr_status_t modperl_child_exit(void *data)
   {
       char *level = NULL;
       server_rec *s = (server_rec *)data;
  -    
  -    modperl_callback_process(MP_CHILD_EXIT_HANDLER, server_pool, s, MP_HOOK_VOID);
  -    
  +
  +    modperl_callback_process(MP_CHILD_EXIT_HANDLER, server_pool, s,
  +                             MP_HOOK_VOID);
  +
       if ((level = getenv("PERL_DESTRUCT_LEVEL"))) {
           modperl_destruct_level = atoi(level);
       }
  @@ -662,6 +675,17 @@
   
       if (modperl_destruct_level) {
           apr_pool_clear(server_pool);
  +    }
  +    else {
  +        /* run the END blocks of this child process if
  +         * modperl_perl_destruct is not called for this process */
  +#ifdef USE_ITHREADS
  +        modperl_interp_mip_walk_servers(NULL, s,
  +                                        modperl_perl_call_endav_mip,
  +                                        (void*)NULL);
  +#else
  +        modperl_perl_call_endav(aTHX);
  +#endif
       }
   
       server_pool = NULL;
  
  
  
  1.27      +0 -63     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.26
  retrieving revision 1.27
  diff -u -u -r1.26 -r1.27
  --- modperl_handler.c	4 Mar 2004 06:01:07 -0000	1.26
  +++ modperl_handler.c	2 Apr 2004 02:17:45 -0000	1.27
  @@ -15,69 +15,6 @@
   
   #include "mod_perl.h"
   
  -#ifdef USE_ITHREADS
  -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.
  -     * 0.6 works fine for non-blessed code refs.
  -     * notice that B::Deparse is not CPAN-updatable.
  -     * 0.61 is available starting from 5.8.0
  -     */
  -    load_module(PERL_LOADMOD_NOIMPORT,
  -                newSVpvn("B::Deparse", 10),
  -                newSVnv(SvOBJECT((SV*)cv) ? 0.61 : 0.60));
  -
  -    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 = apr_pstrcat(p, "sub ", POPpx, NULL);
  -    }
  -    
  -    PUTBACK;
  -    
  -    FREETMPS;
  -    LEAVE;
  -
  -    return text;
  -}
  -#endif
  -
   modperl_handler_t *modperl_handler_new(apr_pool_t *p, const char *name)
   {
       modperl_handler_t *handler = 
  
  
  
  1.22      +10 -5     modperl-2.0/src/modules/perl/modperl_perl.c
  
  Index: modperl_perl.c
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_perl.c,v
  retrieving revision 1.21
  retrieving revision 1.22
  diff -u -u -r1.21 -r1.22
  --- modperl_perl.c	4 Mar 2004 06:01:07 -0000	1.21
  +++ modperl_perl.c	2 Apr 2004 02:17:45 -0000	1.22
  @@ -57,7 +57,7 @@
       ids->gid  = getgid(); 
       ids->gid  = getegid(); 
   
  -    MP_TRACE_g(MP_FUNC, 
  +    MP_TRACE_r(MP_FUNC, 
                  "pid=%d, "
   #ifdef MP_MAINTAIN_PPID
                  "ppid=%d, "
  @@ -120,6 +120,8 @@
   
       PERL_SET_CONTEXT(perl);
   
  +    modperl_perl_call_endav(aTHX);
  +
       PL_perl_destruct_level = modperl_perl_destruct_level();
   
   #ifdef USE_ENVIRON_ARRAY
  @@ -144,10 +146,6 @@
   #   endif
   #endif
   
  -    if (PL_endav) {
  -        modperl_perl_call_list(aTHX_ PL_endav, "END");
  -    }
  -
       {
           dTHXa(perl);
   
  @@ -174,6 +172,13 @@
           environ = orig_environ;
       }
   #endif
  +}
  +
  +void modperl_perl_call_endav(pTHX)
  +{
  +     if (PL_endav) {
  +         modperl_perl_call_list(aTHX_ PL_endav, "END");
  +     }
   }
   
   #if !(PERL_REVISION == 5 && ( PERL_VERSION < 8 ||    \
  
  
  
  1.16      +2 -0      modperl-2.0/src/modules/perl/modperl_perl.h
  
  Index: modperl_perl.h
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_perl.h,v
  retrieving revision 1.15
  retrieving revision 1.16
  diff -u -u -r1.15 -r1.16
  --- modperl_perl.h	4 Mar 2004 06:01:07 -0000	1.15
  +++ modperl_perl.h	2 Apr 2004 02:17:45 -0000	1.16
  @@ -40,6 +40,8 @@
   
   void modperl_perl_destruct(PerlInterpreter *perl);
   
  +void modperl_perl_call_endav(pTHX);
  +
   void modperl_hash_seed_init(apr_pool_t *p);
   
   void modperl_hash_seed_set(pTHX);
  
  
  
  1.21      +102 -45   modperl-2.0/src/modules/perl/modperl_perl_global.c
  
  Index: modperl_perl_global.c
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_perl_global.c,v
  retrieving revision 1.20
  retrieving revision 1.21
  diff -u -u -r1.20 -r1.21
  --- modperl_perl_global.c	18 Mar 2004 22:53:31 -0000	1.20
  +++ modperl_perl_global.c	2 Apr 2004 02:17:45 -0000	1.21
  @@ -21,7 +21,7 @@
       globals->inc.gv    = PL_incgv;
       globals->defout.gv = PL_defoutgv;
       globals->rs.sv     = &PL_rs;
  -    globals->end.av    = &PL_endav;
  +    globals->end.av    = PL_endav;
       globals->end.key   = MP_MODGLOBAL_END;
   }
   
  @@ -65,78 +65,142 @@
       return NULL;
   }
   
  +/*
  + * if (exists $PL_modglobal{$key}{$package}) {
  + *      return $PL_modglobal{$key}{$package};
  + * }
  + * elsif ($autovivify) {
  + *     return $PL_modglobal{$key}{$package} = [];
  + * }
  + * else {
  + *     return $Nullav; # a null pointer in C of course :)
  + * }
  + */
   static AV *modperl_perl_global_avcv_fetch(pTHX_ modperl_modglobal_key_t *gkey,
  -                                          const char *package, I32 packlen)
  +                                          const char *package, I32 packlen,
  +                                          I32 autovivify)
   {
       HE *he = MP_MODGLOBAL_FETCH(gkey);
       HV *hv;
   
       if (!(he && (hv = (HV*)HeVAL(he)))) {
  -        return Nullav;
  +        if (autovivify) {
  +            hv = MP_MODGLOBAL_STORE_HV(gkey);
  +        }
  +        else {
  +            return Nullav;
  +        }
       }
   
  -    if (!(he = hv_fetch_he(hv, (char *)package, packlen, 0))) {
  -        return Nullav;
  +    if ((he = hv_fetch_he(hv, (char *)package, packlen, 0))) {
  +        return (AV*)HeVAL(he);
  +    }
  +    else {
  +        if (autovivify) {
  +            return (AV*)*hv_store(hv, package, packlen, (SV*)newAV(), 0);
  +        }
  +        else {
  +            return Nullav;
  +        }
       }
  +}
  +
  +/* autovivify $PL_modglobal{$key}{$package} if it doesn't exist yet,
  + * so that in modperl_perl_global_avcv_set we will know whether to
  + * store blocks in it or keep them in the original list.
  + *
  + * For example in the case of END blocks, if
  + * $PL_modglobal{END}{$package} exists, modperl_perl_global_avcv_set
  + * will push newly encountered END blocks to it, otherwise it'll keep
  + * them in PL_endav.
  + */
  +void modperl_perl_global_avcv_register(pTHX_ modperl_modglobal_key_t *gkey,
  +                                       const char *package, I32 packlen)
  +{
  +    AV *av = modperl_perl_global_avcv_fetch(aTHX_ gkey,
  +                                            package, packlen, TRUE);
   
  -    return (AV*)HeVAL(he);
  +    MP_TRACE_g(MP_FUNC, "register PL_modglobal %s::%s (has %d entries)",
  +               package, (char*)gkey->name, av ? 1+av_len(av) : 0);
   }
   
  +/* if (exists $PL_modglobal{$key}{$package}) {
  + *     for my $cv (@{ $PL_modglobal{$key}{$package} }) {
  + *         $cv->();
  + *     }
  + * }
  + */
   void modperl_perl_global_avcv_call(pTHX_ modperl_modglobal_key_t *gkey,
                                      const char *package, I32 packlen)
   {
  -    AV *av = modperl_perl_global_avcv_fetch(aTHX_ gkey, package, packlen);
  +    AV *av = modperl_perl_global_avcv_fetch(aTHX_ gkey, package, packlen,
  +                                            FALSE);
   
  -    if (!av) {
  -        return;
  -    }
  +    MP_TRACE_g(MP_FUNC, "run PL_modglobal %s::%s (has %d entries)",
  +               package, (char*)gkey->name, av ? 1+av_len(av) : 0);
   
  -    modperl_perl_call_list(aTHX_ av, gkey->name);
  +    if (av) {
  +        modperl_perl_call_list(aTHX_ av, gkey->name);
  +    }
   }
   
  +
  +/* if (exists $PL_modglobal{$key}{$package}) {
  + *     @{ $PL_modglobal{$key}{$package} } = ();
  + * }
  + */
   void modperl_perl_global_avcv_clear(pTHX_ modperl_modglobal_key_t *gkey,
                                       const char *package, I32 packlen)
   {
  -    AV *av = modperl_perl_global_avcv_fetch(aTHX_ gkey, package, packlen);
  +    AV *av = modperl_perl_global_avcv_fetch(aTHX_ gkey,
  +                                            package, packlen, FALSE);
   
  -    if (!av) {
  -        return;
  +    MP_TRACE_g(MP_FUNC, "clear PL_modglobal %s::%s (has %d entries)",
  +               package, (char*)gkey->name, av ? 1+av_len(av) : 0);
  +    
  +    if (av) {
  +        av_clear(av);
       }
  -
  -    av_clear(av);
   }
   
   static int modperl_perl_global_avcv_set(pTHX_ SV *sv, MAGIC *mg)
   {
  -    HE *he;
  -    HV *hv;
       AV *mav, *av = (AV*)sv;
       const char *package = HvNAME(PL_curstash);
       I32 packlen = strlen(package);
       modperl_modglobal_key_t *gkey =
           (modperl_modglobal_key_t *)mg->mg_ptr;
   
  -    if ((he = MP_MODGLOBAL_FETCH(gkey))) {
  -        hv = (HV*)HeVAL(he);
  -    }
  -    else {
  -        hv = MP_MODGLOBAL_STORE_HV(gkey);
  -    }
  -
  -    if ((he = hv_fetch_he(hv, (char *)package, packlen, 0))) {
  -        mav = (AV*)HeVAL(he);
  -    }
  -    else {
  -        mav = (AV*)*hv_store(hv, package, packlen, (SV*)newAV(), 0);
  -    }
  -
  -    /* $cv = pop @av */
  -    sv = AvARRAY(av)[AvFILLp(av)];
  -    AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef;
  -
  +    /* the argument sv, is the original list perl was operating on.
  +     * (e.g. PL_endav). So now if we find that we have package/cv name
  +     * (e.g. Foo/END) registered for set-aside, we remove the cv that
  +     * was just unshifted in and push it into
  +     * $PL_modglobal{$key}{$package}. Otherwise we do nothing, which
  +     * keeps the unshifted cv (e.g. END block) in its original av
  +     * (e.g. PL_endav)
  +     */
  +     
  +    mav = modperl_perl_global_avcv_fetch(aTHX_ gkey, package, packlen, FALSE);
  +    
  +    if (!mav) {
  +        MP_TRACE_g(MP_FUNC, "%s::%s is not going to PL_modglobal",
  +                   package, (char*)gkey->name);
  +        /* keep it in the tied list (e.g. PL_endav) */
  +        return 1;
  +    }
  +
  +    MP_TRACE_g(MP_FUNC, "%s::%s is going into PL_modglobal",
  +               package, (char*)gkey->name);
  +        
  +    sv = av_shift(av);
  +    
       /* push @{ $PL_modglobal{$key}{$package} }, $cv */
       av_store(mav, AvFILLp(mav)+1, sv);
   
  +    /* print scalar @{ $PL_modglobal{$key}{$package} } */
  +    MP_TRACE_g(MP_FUNC, "%s::%s av now has %d entries\n",
  +               package, (char*)gkey->name, 1+av_len(mav));
  +    
       return 1;
   }
   
  @@ -146,9 +210,6 @@
       0, 0, 0,
   };
   
  -/* XXX: Apache::RegistryLoader type things need access to this
  - * for compiling scripts at startup
  - */
   static void modperl_perl_global_avcv_tie(pTHX_ modperl_modglobal_key_e key,
                                            AV *av)
   {
  @@ -172,17 +233,13 @@
   static void
   modperl_perl_global_avcv_save(pTHX_ modperl_perl_global_avcv_t *avcv)
   {
  -    avcv->origav = *avcv->av;
  -    *avcv->av = newAV(); /* XXX: only need 1 of these AVs per-interpreter */
  -    modperl_perl_global_avcv_tie(aTHX_ avcv->key, *avcv->av);
  +    modperl_perl_global_avcv_tie(aTHX_ avcv->key, avcv->av);
   }
   
   static void
   modperl_perl_global_avcv_restore(pTHX_ modperl_perl_global_avcv_t *avcv)
   {
  -    modperl_perl_global_avcv_untie(aTHX_ *avcv->av);
  -    SvREFCNT_dec(*avcv->av); /* XXX: see XXX above */
  -    *avcv->av = avcv->origav;
  +    modperl_perl_global_avcv_untie(aTHX_ avcv->av);
   }
   
   /*
  
  
  
  1.13      +4 -2      modperl-2.0/src/modules/perl/modperl_perl_global.h
  
  Index: modperl_perl_global.h
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_perl_global.h,v
  retrieving revision 1.12
  retrieving revision 1.13
  diff -u -u -r1.12 -r1.13
  --- modperl_perl_global.h	4 Mar 2004 06:01:07 -0000	1.12
  +++ modperl_perl_global.h	2 Apr 2004 02:17:45 -0000	1.13
  @@ -28,8 +28,7 @@
   } modperl_modglobal_key_e;
   
   typedef struct {
  -    AV **av;
  -    AV *origav;
  +    AV *av;
       modperl_modglobal_key_e key;
   } modperl_perl_global_avcv_t;
   
  @@ -71,6 +70,9 @@
   void modperl_perl_global_request_save(pTHX_ request_rec *r);
   
   void modperl_perl_global_request_restore(pTHX_ request_rec *r);
  +
  +void modperl_perl_global_avcv_register(pTHX_ modperl_modglobal_key_t *gkey,
  +                                       const char *package, I32 packlen);
   
   void modperl_perl_global_avcv_call(pTHX_ modperl_modglobal_key_t *gkey,
                                      const char *package, I32 packlen);
  
  
  
  1.65      +116 -25   modperl-2.0/src/modules/perl/modperl_util.c
  
  Index: modperl_util.c
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.c,v
  retrieving revision 1.64
  retrieving revision 1.65
  diff -u -u -r1.64 -r1.65
  --- modperl_util.c	5 Mar 2004 18:19:15 -0000	1.64
  +++ modperl_util.c	2 Apr 2004 02:17:45 -0000	1.65
  @@ -338,7 +338,7 @@
       void **handles;
   
       if (!librefs) {
  -	MP_TRACE_g(MP_FUNC,
  +	MP_TRACE_r(MP_FUNC,
                      "Could not get @%s for unloading.\n",
                      dl_librefs);
   	return NULL;
  @@ -357,14 +357,14 @@
   	SV *module_sv = *av_fetch(modules, i, FALSE);
   
   	if(!handle_sv) {
  -	    MP_TRACE_g(MP_FUNC,
  +	    MP_TRACE_r(MP_FUNC,
                          "Could not fetch $%s[%d]!\n",
                          dl_librefs, (int)i);
   	    continue;
   	}
   	handle = (void *)SvIV(handle_sv);
   
  -	MP_TRACE_g(MP_FUNC, "%s dl handle == 0x%lx\n",
  +	MP_TRACE_r(MP_FUNC, "%s dl handle == 0x%lx\n",
                      SvPVX(module_sv), (unsigned long)handle);
   	if (handle) {
   	    handles[i] = handle;
  @@ -388,7 +388,7 @@
       }
   
       for (i=0; handles[i]; i++) {
  -        MP_TRACE_g(MP_FUNC, "close 0x%lx\n", (unsigned long)handles[i]);
  +        MP_TRACE_r(MP_FUNC, "close 0x%lx\n", (unsigned long)handles[i]);
           modperl_sys_dlclose(handles[i]);
       }
   
  @@ -544,6 +544,13 @@
   {
       I32 i, oldscope = PL_scopestack_ix;
       SV **ary = AvARRAY(subs);
  +
  +    /* XXX: why this trace doesn't get printed to error_log when this
  +     * method is called from modperl_perl_destruct. Perl_warn works
  +     * just fine. may be we need to switch to perl_warn when apache
  +     * closes the logging api (when?) */
  +    MP_TRACE_g(MP_FUNC, "pid %lu running %d %s subs",
  +               (unsigned long)getpid(), AvFILLp(subs)+1, name);
       
       for (i=0; i<=AvFILLp(subs); i++) {
   	CV *cv = (CV*)ary[i];
  @@ -764,27 +771,6 @@
       return newRV_noinc(sv);
   }
   
  -#ifdef MP_TRACE
  -/* XXX: internal debug function */
  -/* any non-false value for MOD_PERL_TRACE/PerlTrace enables this function */
  -void modperl_apr_table_dump(pTHX_ apr_table_t *table, char *name)
  -{
  -    int i;
  -    const apr_array_header_t *array;
  -    apr_table_entry_t *elts;
  -
  -    array = apr_table_elts(table);
  -    elts  = (apr_table_entry_t *)array->elts;
  -    modperl_trace(MP_FUNC, "Contents of table %s", name);
  -    for (i = 0; i < array->nelts; i++) {
  -        if (!elts[i].key || !elts[i].val) {
  -            continue;
  -        }
  -        modperl_trace(MP_FUNC, "%s => %s", elts[i].key, elts[i].val);
  -    }    
  -}
  -#endif
  -
   #define MP_VALID_PKG_CHAR(c) (isalnum(c) ||(c) == '_')
   #define MP_VALID_PATH_DELIM(c) ((c) == '/' || (c) =='\\')
   char *modperl_file2package(apr_pool_t *p, const char *file)
  @@ -858,3 +844,108 @@
       /* copy the SV in case the pool goes out of scope before the perl scalar */
       return newSVpv(ap_server_root_relative(p, fname), 0);
   }
  +
  +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.
  +     * 0.6 works fine for non-blessed code refs.
  +     * notice that B::Deparse is not CPAN-updatable.
  +     * 0.61 is available starting from 5.8.0
  +     */
  +    load_module(PERL_LOADMOD_NOIMPORT,
  +                newSVpvn("B::Deparse", 10),
  +                newSVnv(SvOBJECT((SV*)cv) ? 0.61 : 0.60));
  +
  +    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 = apr_pstrcat(p, "sub ", POPpx, NULL);
  +    }
  +    
  +    PUTBACK;
  +    
  +    FREETMPS;
  +    LEAVE;
  +
  +    return text;
  +}
  +
  +#ifdef MP_TRACE
  +
  +/* XXX: internal debug function, a candidate for modperl_debug.c */
  +/* any non-false value for MOD_PERL_TRACE/PerlTrace enables this function */
  +void modperl_apr_table_dump(pTHX_ apr_table_t *table, char *name)
  +{
  +    int i;
  +    const apr_array_header_t *array;
  +    apr_table_entry_t *elts;
  +
  +    array = apr_table_elts(table);
  +    elts  = (apr_table_entry_t *)array->elts;
  +    modperl_trace(MP_FUNC, "Contents of table %s", name);
  +    for (i = 0; i < array->nelts; i++) {
  +        if (!elts[i].key || !elts[i].val) {
  +            continue;
  +        }
  +        modperl_trace(MP_FUNC, "%s => %s", elts[i].key, elts[i].val);
  +    }    
  +}
  +
  +/* XXX: internal debug function, a candidate for modperl_debug.c */
  +void modperl_perl_modglobal_dump(pTHX)
  +{
  +    HV *hv = PL_modglobal;
  +    AV *val;
  +    char *key;
  +    I32 klen;
  +    hv_iterinit(hv);
  +
  +    MP_TRACE_g(MP_FUNC, "|-------- PL_modglobal --------");
  +    MP_TRACE_g(MP_FUNC, "| perl 0x%lx PL_modglobal 0x%lx",
  +               (unsigned long)aTHX, (unsigned long)PL_modglobal);
  +    
  +    while ((val = (AV*)hv_iternextsv(hv, &key, &klen))) {
  +        MP_TRACE_g(MP_FUNC, "| %s => 0x%lx", key, val);
  +    }
  +    
  +    MP_TRACE_g(MP_FUNC, "|-------- PL_modglobal --------\n");
  +        
  +}
  +
  +
  +#endif
  
  
  
  1.53      +16 -3     modperl-2.0/src/modules/perl/modperl_util.h
  
  Index: modperl_util.h
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.h,v
  retrieving revision 1.52
  retrieving revision 1.53
  diff -u -u -r1.52 -r1.53
  --- modperl_util.h	4 Mar 2004 06:01:07 -0000	1.52
  +++ modperl_util.h	2 Apr 2004 02:17:45 -0000	1.53
  @@ -169,12 +169,25 @@
   
   void modperl_clear_symtab(pTHX_ HV *symtab);
   
  +char *modperl_file2package(apr_pool_t *p, const char *file);
  +
  +SV *modperl_server_root_relative(pTHX_ SV *sv, const char *fname);
  +
  +/**
  + * convert a compiled *CV ref to its original source code
  + * @param p       pool object (with a shortest possible life scope)
  + * @param cv      compiled *CV
  + * @return string of original source code
  + */
  +char *modperl_coderef2text(pTHX_ apr_pool_t *p, CV *cv);
  +
   #ifdef MP_TRACE
  +
   void modperl_apr_table_dump(pTHX_ apr_table_t *table, char *name);
  -#endif
   
  -char *modperl_file2package(apr_pool_t *p, const char *file);
  +/* dump the contents of PL_modglobal */
  +void modperl_perl_modglobal_dump(pTHX);
   
  -SV *modperl_server_root_relative(pTHX_ SV *sv, const char *fname);
  +#endif
   
   #endif /* MODPERL_UTIL_H */
  
  
  
  1.3       +14 -4     modperl-2.0/t/response/TestModperl/endav.pm
  
  Index: endav.pm
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/t/response/TestModperl/endav.pm,v
  retrieving revision 1.2
  retrieving revision 1.3
  diff -u -u -r1.2 -r1.3
  --- endav.pm	11 Apr 2002 11:08:44 -0000	1.2
  +++ endav.pm	2 Apr 2004 02:17:46 -0000	1.3
  @@ -17,27 +17,37 @@
       #just to make sure we dont segv with bogus values
       my $not = 'NoSuchPackage';
       for my $name ('END', $not) {
  -        ModPerl::Global::special_list_call($name => $not);
  +        ModPerl::Global::special_list_call( $name => $not);
           ModPerl::Global::special_list_clear($name => $not);
       }
   
  +    # register the current package to set its END blocks aside
  +    ModPerl::Global::special_list_register(END => __PACKAGE__);
  +    # clear anything that was previously set
  +    ModPerl::Global::special_list_clear(END => __PACKAGE__);
       eval 'END { ok 1 }';
   
  +    # now run them twice:ok 1 (1), ok 1 (2)
       ModPerl::Global::special_list_call(END => __PACKAGE__);
       ModPerl::Global::special_list_call(END => __PACKAGE__);
   
       ModPerl::Global::special_list_clear(END => __PACKAGE__);
       #should do nothing
  -    ModPerl::Global::special_list_call(END => __PACKAGE__);
  +    ModPerl::Global::special_list_call( END => __PACKAGE__);
   
  +    # this we've already registered this package's END blocks, adding
  +    # new ones will set them aside
       eval 'END { ok 1 }';
  -    ModPerl::Global::special_list_call(END => __PACKAGE__);
  +
  +    # so this will run ok 1 (3)
  +    ModPerl::Global::special_list_call( END => __PACKAGE__);
       ModPerl::Global::special_list_clear(END => __PACKAGE__);
   
       ModPerl::Global::special_list_clear(END => __PACKAGE__);
       #should do nothing
  -    ModPerl::Global::special_list_call(END => __PACKAGE__);
  +    ModPerl::Global::special_list_call( END => __PACKAGE__);
   
  +    # one plain ok 1 (4)
       ok 1;
   
       Apache::OK;
  
  
  
  1.5       +9 -0      modperl-2.0/xs/ModPerl/Global/ModPerl__Global.h
  
  Index: ModPerl__Global.h
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/xs/ModPerl/Global/ModPerl__Global.h,v
  retrieving revision 1.4
  retrieving revision 1.5
  diff -u -u -r1.4 -r1.5
  --- ModPerl__Global.h	4 Mar 2004 06:01:13 -0000	1.4
  +++ ModPerl__Global.h	2 Apr 2004 02:17:46 -0000	1.5
  @@ -50,3 +50,12 @@
       return mpxs_special_list_do(aTHX_ name, package,
                                   modperl_perl_global_avcv_clear);
   }
  +
  +static
  +MP_INLINE int mpxs_ModPerl__Global_special_list_register(pTHX_
  +                                                         const char *name,
  +                                                         SV *package)
  +{
  +    return mpxs_special_list_do(aTHX_ name, package,
  +                                modperl_perl_global_avcv_register);
  +}
  
  
  
  1.71      +1 -0      modperl-2.0/xs/maps/modperl_functions.map
  
  Index: modperl_functions.map
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/xs/maps/modperl_functions.map,v
  retrieving revision 1.70
  retrieving revision 1.71
  diff -u -u -r1.70 -r1.71
  --- modperl_functions.map	5 Mar 2004 18:19:15 -0000	1.70
  +++ modperl_functions.map	2 Apr 2004 02:17:46 -0000	1.71
  @@ -10,6 +10,7 @@
   MODULE=ModPerl::Global
    mpxs_ModPerl__Global_special_list_call
    mpxs_ModPerl__Global_special_list_clear
  + mpxs_ModPerl__Global_special_list_register
   
   MODULE=Apache::RequestRec   PACKAGE=Apache::RequestRec
    mpxs_Apache__RequestRec_content_type   | | r, type=Nullsv
  
  
  
  1.149     +61 -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.148
  retrieving revision 1.149
  diff -u -u -r1.148 -r1.149
  --- FunctionTable.pm	3 Mar 2004 06:29:33 -0000	1.148
  +++ FunctionTable.pm	2 Apr 2004 02:17:46 -0000	1.149
  @@ -3839,6 +3839,28 @@
     },
     {
       'return_type' => 'void',
  +    'name' => 'modperl_perl_global_avcv_register',
  +    'args' => [
  +      {
  +        'type' => 'PerlInterpreter *',
  +        'name' => 'my_perl'
  +      },
  +      {
  +        'type' => 'modperl_modglobal_key_t *',
  +        'name' => 'gkey'
  +      },
  +      {
  +        'type' => 'const char *',
  +        'name' => 'package'
  +      },
  +      {
  +        'type' => 'I32',
  +        'name' => 'packlen'
  +      }
  +    ]
  +  },
  +  {
  +    'return_type' => 'void',
       'name' => 'modperl_perl_global_request_restore',
       'args' => [
         {
  @@ -6191,6 +6213,27 @@
       ]
     },
     {
  +    'return_type' => 'int',
  +    'name' => 'mpxs_ModPerl__Global_special_list_register',
  +    'attr' => [
  +      '__inline__'
  +    ],
  +    'args' => [
  +      {
  +        'type' => 'PerlInterpreter *',
  +        'name' => 'my_perl'
  +      },
  +      {
  +        'type' => 'const char *',
  +        'name' => 'name'
  +      },
  +      {
  +        'type' => 'SV *',
  +        'name' => 'package'
  +      }
  +    ]
  +  },
  +  {
       'return_type' => 'void',
       'name' => 'mpxs_ModPerl__Util_untaint',
       'attr' => [
  @@ -6414,6 +6457,24 @@
         {
           'type' => 'const char *',
           'name' => 'fname'
  +      }
  +    ]
  +  },
  +  {
  +    'return_type' => 'char *',
  +    'name' => 'modperl_coderef2text',
  +    'args' => [
  +      {
  +        'type' => 'PerlInterpreter *',
  +        'name' => 'my_perl'
  +      },
  +      {
  +        'type' => 'apr_pool_t *',
  +        'name' => 'p'
  +      },
  +      {
  +        'type' => 'CV *',
  +        'name' => 'cv'
         }
       ]
     },
  
  
  
  1.355     +11 -0     modperl-2.0/Changes
  
  Index: Changes
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/Changes,v
  retrieving revision 1.354
  retrieving revision 1.355
  diff -u -u -r1.354 -r1.355
  --- Changes	26 Mar 2004 22:17:07 -0000	1.354
  +++ Changes	2 Apr 2004 02:17:46 -0000	1.355
  @@ -12,6 +12,17 @@
   
   =item 1.99_14-dev
   
  +'SetHandler perl-script' no longer grabs any newly encountered END
  +blocks, and removes them from PL_endav, but only if they are
  +explicitly registered via ModPerl::Global::special_list_register(END
  +=> $package_name) (this is a new function). It's now possible to have
  +a complete control of when END blocks are run from the user space, not
  +only in the registry handlers [Stas]
  +
  +END blocks encountered by child processes and not hijacked by
  +ModPerl::Global::special_list_register() are now executed at the
  +server shutdown (previously they weren't executed at all). [Stas]
  +
   Added test to ensure <Perl> sections can have things like %Location
   tied [Gozer]
   
  
  
  
  1.20      +0 -13     modperl-2.0/todo/release
  
  Index: release
  ===================================================================
  RCS file: /home/cvs/modperl-2.0/todo/release,v
  retrieving revision 1.19
  retrieving revision 1.20
  diff -u -u -r1.19 -r1.20
  --- release	4 Mar 2004 01:09:50 -0000	1.19
  +++ release	2 Apr 2004 02:17:46 -0000	1.20
  @@ -52,19 +52,6 @@
       Apache->server->process->pconf->cleanup_register(sub { ...  });
     Report: geoff
   
  -* child processes never run END blocks. a good example is
  -  Apache::TestUtil, which doesn't cleanup files and dirs it has
  -  created, because the END block is not run.
  -  also: see the next item
  -  owner: stas
  -
  -* ModPerl::Registry END {} block woes , described in details at the
  -  forwarded message from Jim Schueler
  -  http://marc.theaimsgroup.com/?l=apache-modperl&m=103720834717981&w=2
  -  the whole thread is here:
  -  http://marc.theaimsgroup.com/?t=103713532800003&r=1&w=2
  -  owner: stas
  -
   - PerlModule, PerlRequire, <Perl> in .htaccess is missing
     http://marc.theaimsgroup.com/?t=105370088700001&r=1&w=2
     Owner: geoff
  
  
  

Mime
View raw message