This new patch addresses the issue Geoff pointed out. Deleting package Foo, shouldn't delete package Foo::Bar.
It actually makes the patch a bit simpler, deleting all entries in the package's stash only skipping the ones ending in '::'. Still works like a charm for me.
More Comments ?
-- -------------------------------------------------------------------------------- Philippe M. Chiasson m/gozer\@(apache|cpan|ectoplasm)\.org/ GPG KeyID : 88C3A5A5 http://gozer.ectoplasm.org/ F9BF E0C2 480E 7680 1AE5 3631 CB32 A107 88C3A5A5
? core.30884
Index: ModPerl-Registry/lib/ModPerl/RegistryCooker.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/ModPerl-Registry/lib/ModPerl/RegistryCooker.pm,v
retrieving revision 1.50
diff -u -I$Id -r1.50 RegistryCooker.pm
--- ModPerl-Registry/lib/ModPerl/RegistryCooker.pm 27 Jun 2004 21:26:45 -0000 1.50
+++ ModPerl-Registry/lib/ModPerl/RegistryCooker.pm 24 Aug 2004 19:17:08 -0000
@@ -526,47 +526,7 @@
$self->debug("flushing namespace") if DEBUG & D_NOISE;
- no strict 'refs';
- my $tab = \%{ $self->{PACKAGE} . '::' };
-
- # below we assign to a symbol first before undef'ing it, to avoid
- # nuking aliases. If we undef directly we may undef not only the
- # alias but the original function as well
-
- for (keys %$tab) {
- my $fullname = join '::', $self->{PACKAGE}, $_;
- # code/hash/array/scalar might be imported make sure the gv
- # does not point elsewhere before undefing each
- if (%$fullname) {
- *{$fullname} = {};
- undef %$fullname;
- }
- if (@$fullname) {
- *{$fullname} = [];
- undef @$fullname;
- }
- if ($$fullname) {
- my $tmp; # argh, no such thing as an anonymous scalar
- *{$fullname} = \$tmp;
- undef $$fullname;
- }
- if (defined &$fullname) {
- no warnings;
- local $^W = 0;
- if (defined(my $p = prototype $fullname)) {
- *{$fullname} = eval "sub ($p) {}";
- }
- else {
- *{$fullname} = sub {};
- }
- undef &$fullname;
- }
- if (*{$fullname}{IO}) {
- if (fileno $fullname) {
- close $fullname;
- }
- }
- }
+ ModPerl::Util::clear_namespace($self->{REQ}->pool, $self->{PACKAGE});
}
Index: lib/Apache/Reload.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/lib/Apache/Reload.pm,v
retrieving revision 1.14
diff -u -I$Id -r1.14 Reload.pm
--- lib/Apache/Reload.pm 11 Mar 2004 06:34:24 -0000 1.14
+++ lib/Apache/Reload.pm 24 Aug 2004 19:17:08 -0000
@@ -27,6 +27,8 @@
use Apache::ServerUtil;
use Apache::RequestUtil;
+use ModPerl::Util;
+
use vars qw(%INCS %Stat $TouchTime %UndefFields);
%Stat = ($INC{"Apache/Reload.pm"} => time);
@@ -47,6 +49,13 @@
return $package;
}
+sub module_to_package {
+ my $module = shift;
+ $module =~ s/\//::/g;
+ $module =~ s/\.pm$//g;
+ return $module;
+}
+
sub register_module {
my($class, $package, $file) = @_;
my $module = package_to_module($package);
@@ -59,11 +68,6 @@
return unless $file;
$INCS{$module} = $file;
}
-
- no strict 'refs';
- if (%{"${package}::FIELDS"}) {
- $UndefFields{$module} = "${package}::FIELDS";
- }
}
# the first argument is:
@@ -110,15 +114,6 @@
foreach my $match (keys %INC) {
if ($match =~ /^\Q$prefix\E/) {
$Apache::Reload::INCS{$match} = $INC{$match};
- my $package = $match;
- $package =~ s/\//::/g;
- $package =~ s/\.pm$//;
- no strict 'refs';
-# warn "checking for FIELDS on $package\n";
- if (%{"${package}::FIELDS"}) {
-# warn "found fields in $package\n";
- $UndefFields{$match} = "${package}::FIELDS";
- }
}
}
}
@@ -152,29 +147,16 @@
}
if ($mtime > $Stat{$file}) {
- delete $INC{$key};
-# warn "Reloading $key\n";
- if (my $symref = $UndefFields{$key}) {
-# warn "undeffing fields\n";
- no strict 'refs';
- undef %{$symref};
- }
- no warnings FATAL => 'all';
- local $SIG{__WARN__} = \&skip_redefine_const_sub_warn
- unless $ConstantRedefineWarnings;
+ my $package = module_to_package($key);
+ ModPerl::Util::clear_namespace($o->pool, $package);
require $key;
- warn("Apache::Reload: process $$ reloading $key\n")
+ warn("Apache::Reload: process $$ reloading $package from $key\n")
if $DEBUG;
}
$Stat{$file} = $mtime;
}
return Apache::OK;
-}
-
-sub skip_redefine_const_sub_warn {
- return if $_[0] =~ /^Constant subroutine [\w:]+ redefined at/;
- CORE::warn(@_);
}
1;
Index: src/modules/perl/modperl_cmd.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_cmd.c,v
retrieving revision 1.64
diff -u -I$Id -r1.64 modperl_cmd.c
--- src/modules/perl/modperl_cmd.c 23 Aug 2004 21:16:27 -0000 1.64
+++ src/modules/perl/modperl_cmd.c 24 Aug 2004 19:17:08 -0000
@@ -577,10 +577,7 @@
SvREFCNT_dec((SV*)args);
if (!(saveconfig && SvTRUE(saveconfig))) {
- HV *symtab = (HV*)gv_stashpv(pkg_name, FALSE);
- if (symtab) {
- modperl_clear_symtab(aTHX_ symtab);
- }
+ modperl_clear_stash(aTHX_ p, pkg_name);
}
if (status != OK) {
Index: src/modules/perl/modperl_mgv.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_mgv.c,v
retrieving revision 1.35
diff -u -I$Id -r1.35 modperl_mgv.c
--- src/modules/perl/modperl_mgv.c 4 Mar 2004 06:01:07 -0000 1.35
+++ src/modules/perl/modperl_mgv.c 24 Aug 2004 19:17:08 -0000
@@ -171,32 +171,6 @@
}
#endif
-
-static void package2filename(apr_pool_t *p, const char *package,
- char **filename, int *len)
-{
- const char *s;
- char *d;
-
- *filename = apr_palloc(p, (strlen(package)+4)*sizeof(char));
-
- for (s = package, d = *filename; *s; s++, d++) {
- if (*s == ':' && s[1] == ':') {
- *d = '/';
- s++;
- }
- else {
- *d = *s;
- }
- }
- *d++ = '.';
- *d++ = 'p';
- *d++ = 'm';
- *d = '\0';
-
- *len = d - *filename;
-}
-
/* currently used for complex filters attributes parsing */
/* XXX: may want to generalize it for any handlers */
#define MODPERL_MGV_DEEP_RESOLVE(handler, p) \
@@ -285,7 +259,7 @@
char *filename;
SV **svp;
- package2filename(p, name, &filename, &len);
+ modperl_package2filename(p, name, &filename, &len);
svp = hv_fetch(GvHVn(PL_incgv), filename, len, 0);
if (!(svp && *svp != &PL_sv_undef)) { /* not in %INC */
Index: src/modules/perl/modperl_util.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.c,v
retrieving revision 1.76
diff -u -I$Id -r1.76 modperl_util.c
--- src/modules/perl/modperl_util.c 22 Aug 2004 20:47:37 -0000 1.76
+++ src/modules/perl/modperl_util.c 24 Aug 2004 19:17:08 -0000
@@ -491,60 +491,6 @@
return (*name && gv_stashpv(name, FALSE)) ? 1 : 0;
}
-static int modperl_gvhv_is_stash(GV *gv)
-{
- int len = GvNAMELEN(gv);
- char *name = GvNAME(gv);
-
- if ((len > 2) && (name[len - 1] == ':') && (name[len - 2] == ':')) {
- return 1;
- }
-
- return 0;
-}
-
-/*
- * we do not clear symbols within packages, the desired behavior
- * for directive handler classes. and there should never be a package
- * within the %Apache::ReadConfig. nothing else that i'm aware of calls
- * this function, so we should be ok.
- */
-
-void modperl_clear_symtab(pTHX_ HV *symtab)
-{
- SV *val;
- char *key;
- I32 klen;
-
- hv_iterinit(symtab);
-
- while ((val = hv_iternextsv(symtab, &key, &klen))) {
- SV *sv;
- HV *hv;
- AV *av;
- CV *cv;
-
- if ((SvTYPE(val) != SVt_PVGV) || GvIMPORTED((GV*)val)) {
- continue;
- }
- if ((sv = GvSV((GV*)val))) {
- sv_setsv(GvSV((GV*)val), &PL_sv_undef);
- }
- if ((hv = GvHV((GV*)val)) && !modperl_gvhv_is_stash((GV*)val)) {
- hv_clear(hv);
- }
- if ((av = GvAV((GV*)val))) {
- av_clear(av);
- }
- if ((cv = GvCV((GV*)val)) && (GvSTASH((GV*)val) == GvSTASH(CvGV(cv)))) {
- GV *gv = CvGV(cv);
- cv_undef(cv);
- CvGV(cv) = gv;
- GvCVGEN(gv) = 1; /* invalidate method cache */
- }
- }
-}
-
#define SLURP_SUCCESS(action) \
if (rc != APR_SUCCESS) { \
SvREFCNT_dec(sv); \
@@ -749,4 +695,75 @@
}
return array;
+}
+
+void modperl_package2filename(apr_pool_t *p, const char *package,
+ char **filename, int *len)
+{
+ const char *s;
+ char *d;
+
+ *filename = apr_palloc(p, (strlen(package)+4)*sizeof(char));
+
+ for (s = package, d = *filename; *s; s++, d++) {
+ if (*s == ':' && s[1] == ':') {
+ *d = '/';
+ s++;
+ }
+ else {
+ *d = *s;
+ }
+ }
+ *d++ = '.';
+ *d++ = 'p';
+ *d++ = 'm';
+ *d = '\0';
+
+ *len = d - *filename;
+}
+
+void modperl_clear_stash(pTHX_ apr_pool_t *p, const char *package)
+{
+ HV *stash;
+
+ /* Short-circuit out if the package doesn't exist */
+ if (!modperl_perl_module_loaded(aTHX_ package)) {
+ return;
+ }
+
+ if ((stash = gv_stashpv(package, FALSE))) {
+ HE *he;
+ I32 len;
+ char *key;
+ hv_iterinit(stash);
+ while ((he = hv_iternext(stash))) {
+ key = hv_iterkey(he, &len);
+ if (len > 2 && key[len] != ':' && key[len-1] != ':') {
+ hv_delete(stash, key, len, G_DISCARD);
+ }
+ }
+ }
+}
+
+static void modperl_delete_from_inc(pTHX_ apr_pool_t *p,
+ const char *package)
+{
+ int len;
+ char *filename;
+
+ modperl_package2filename(p, package, &filename, &len);
+ hv_delete(GvHVn(PL_incgv), filename, len, G_DISCARD);
+
+ return;
+}
+
+void modperl_clear_namespace(pTHX_ apr_pool_t *p, const char *package)
+{
+ /* delete $INC{'Some/Package.pm} */
+ modperl_delete_from_inc(aTHX_ p, package);
+
+ /* delete $Some::{'Package::'}; */
+ modperl_clear_stash(aTHX_ p, package);
+
+ return;
}
Index: src/modules/perl/modperl_util.h
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.h,v
retrieving revision 1.66
diff -u -I$Id -r1.66 modperl_util.h
--- src/modules/perl/modperl_util.h 22 Aug 2004 20:47:37 -0000 1.66
+++ src/modules/perl/modperl_util.h 24 Aug 2004 19:17:08 -0000
@@ -94,8 +94,6 @@
*/
SV *modperl_slurp_filename(pTHX_ request_rec *r, int tainted);
-void modperl_clear_symtab(pTHX_ HV *symtab);
-
char *modperl_file2package(apr_pool_t *p, const char *file);
/**
@@ -105,6 +103,11 @@
* @return string of original source code
*/
char *modperl_coderef2text(pTHX_ apr_pool_t *p, CV *cv);
+
+void modperl_clear_namespace(pTHX_ apr_pool_t *p, const char *package);
+void modperl_clear_stash(pTHX_ apr_pool_t *p, const char *package);
+void modperl_package2filename(apr_pool_t *p, const char *package,
+ char **filename, int *len);
SV *modperl_apr_array_header2avrv(pTHX_ apr_array_header_t *array);
apr_array_header_t *modperl_avrv2apr_array_header(pTHX_ apr_pool_t *p,
Index: t/response/TestModules/reload.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/response/TestModules/reload.pm,v
retrieving revision 1.1
diff -u -I$Id -r1.1 reload.pm
--- t/response/TestModules/reload.pm 24 Aug 2004 17:36:56 -0000 1.1
+++ t/response/TestModules/reload.pm 24 Aug 2004 19:17:08 -0000
@@ -5,6 +5,8 @@
use Apache::Const -compile => qw(OK);
+use ModPerl::Util;
+
sub handler {
my $r = shift;
@@ -21,5 +23,4 @@
PerlModule Apache::Reload
PerlInitHandler Apache::TestHandler::same_interp_fixup Apache::Reload
PerlSetVar ReloadDebug On
-PerlSetVar ReloadConstantRedefineWarnings Off
PerlSetVar ReloadAll Off
Index: xs/ModPerl/Util/ModPerl__Util.h
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/ModPerl/Util/ModPerl__Util.h,v
retrieving revision 1.5
diff -u -I$Id -r1.5 ModPerl__Util.h
--- xs/ModPerl/Util/ModPerl__Util.h 4 Mar 2004 06:01:14 -0000 1.5
+++ xs/ModPerl/Util/ModPerl__Util.h 24 Aug 2004 19:17:08 -0000
@@ -28,5 +28,5 @@
#define mpxs_Apache_current_callback modperl_callback_current_callback_get
-
+#define mpxs_ModPerl__Util_clear_namespace(p, pkg) modperl_clear_namespace(aTHX_ p, pkg)
Index: xs/maps/modperl_functions.map
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/maps/modperl_functions.map,v
retrieving revision 1.84
diff -u -I$Id -r1.84 modperl_functions.map
--- xs/maps/modperl_functions.map 22 Aug 2004 20:47:37 -0000 1.84
+++ xs/maps/modperl_functions.map 24 Aug 2004 19:17:08 -0000
@@ -5,6 +5,7 @@
MODULE=ModPerl::Util
mpxs_ModPerl__Util_untaint | | ...
+ DEFINE_clear_namespace | | apr_pool_t *:p, const char *:pkg
DEFINE_exit | | int:status=0
PACKAGE=Apache
Index: xs/tables/current/ModPerl/FunctionTable.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/tables/current/ModPerl/FunctionTable.pm,v
retrieving revision 1.175
diff -u -I$Id -r1.175 FunctionTable.pm
--- xs/tables/current/ModPerl/FunctionTable.pm 22 Aug 2004 20:47:37 -0000 1.175
+++ xs/tables/current/ModPerl/FunctionTable.pm 24 Aug 2004 19:17:08 -0000
@@ -2,7 +2,7 @@
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# ! WARNING: generated by ModPerl::ParseSource/0.01
-# ! Fri Aug 20 12:01:12 2004
+# ! Tue Aug 24 00:11:10 2004
# ! do NOT edit, any changes will be lost !
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -360,15 +360,37 @@
},
{
'return_type' => 'void',
- 'name' => 'modperl_clear_symtab',
+ 'name' => 'modperl_clear_namespace',
'args' => [
{
'type' => 'PerlInterpreter *',
'name' => 'my_perl'
},
{
- 'type' => 'HV *',
- 'name' => 'symtab'
+ 'type' => 'apr_pool_t *',
+ 'name' => 'p'
+ },
+ {
+ 'type' => 'const char *',
+ 'name' => 'package'
+ }
+ ]
+ },
+ {
+ 'return_type' => 'void',
+ 'name' => 'modperl_clear_stash',
+ 'args' => [
+ {
+ 'type' => 'PerlInterpreter *',
+ 'name' => 'my_perl'
+ },
+ {
+ 'type' => 'apr_pool_t *',
+ 'name' => 'p'
+ },
+ {
+ 'type' => 'const char *',
+ 'name' => 'package'
}
]
},
@@ -3874,6 +3896,28 @@
},
{
'type' => 'apr_size_t *',
+ 'name' => 'len'
+ }
+ ]
+ },
+ {
+ 'return_type' => 'void',
+ 'name' => 'modperl_package2filename',
+ 'args' => [
+ {
+ 'type' => 'apr_pool_t *',
+ 'name' => 'p'
+ },
+ {
+ 'type' => 'const char *',
+ 'name' => 'package'
+ },
+ {
+ 'type' => 'char **',
+ 'name' => 'filename'
+ },
+ {
+ 'type' => 'int *',
'name' => 'len'
}
]
signature.asc
Description: OpenPGP digital signature
