Return-Path: Delivered-To: apmail-perl-modperl-cvs-archive@www.apache.org Received: (qmail 30341 invoked from network); 2 Apr 2004 02:17:47 -0000 Received: from daedalus.apache.org (HELO mail.apache.org) (208.185.179.12) by minotaur-2.apache.org with SMTP; 2 Apr 2004 02:17:47 -0000 Received: (qmail 4818 invoked by uid 500); 2 Apr 2004 02:17:31 -0000 Delivered-To: apmail-perl-modperl-cvs-archive@perl.apache.org Received: (qmail 4803 invoked by uid 500); 2 Apr 2004 02:17:30 -0000 Mailing-List: contact modperl-cvs-help@perl.apache.org; run by ezmlm Precedence: bulk list-help: list-unsubscribe: list-post: Reply-To: dev@perl.apache.org Delivered-To: mailing list modperl-cvs@perl.apache.org Received: (qmail 4789 invoked by uid 500); 2 Apr 2004 02:17:30 -0000 Delivered-To: apmail-modperl-2.0-cvs@apache.org Date: 2 Apr 2004 02:17:47 -0000 Message-ID: <20040402021747.30335.qmail@minotaur.apache.org> From: stas@apache.org To: modperl-2.0-cvs@apache.org Subject: cvs commit: modperl-2.0/todo release X-Spam-Rating: daedalus.apache.org 1.6.2 0/1000/N X-Spam-Rating: minotaur-2.apache.org 1.6.2 0/1000/N 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 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, in .htaccess is missing http://marc.theaimsgroup.com/?t=105370088700001&r=1&w=2 Owner: geoff