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
