After not getting substancial noise back from p5p, I've finalized my prototypical package unloading code into a lean XS implementation.
Attached is once again a patch that gets rid of the clear_symtab() approach and goes for the stash wiping method (added complication from dealing with DynaLoaded modules).
This approach might have problems, but it's certainly a better approach than the current one. So unless there is anything terribly wrong with this, I'd like to see it go in. If problems show up in the future, I'll address them.
Thoughts ? -- -------------------------------------------------------------------------------- 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
Index: Changes
===================================================================
RCS file: /home/cvs/modperl-2.0/Changes,v
retrieving revision 1.474
diff -u -I$Id -r1.474 Changes
--- Changes 8 Sep 2004 04:10:09 -0000 1.474
+++ Changes 8 Sep 2004 23:33:18 -0000
@@ -12,6 +12,9 @@
=item 1.99_17-dev
+Added ModPerl::Util::unload_package() to remove a loaded package
+as thoroughly as possible by clearing it's stash. [Gozer]
+
Fix a glue_pod make target bug, when .pm file doesn't exist,
e.g. ThreadMutex.pm is not created on unless
$apr_config->{HAS_THREADS} [Stas]
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 8 Sep 2004 23:33:18 -0000
@@ -525,48 +525,7 @@
my $self = shift;
$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::unload_package($self->{PACKAGE});
}
Index: docs/api/Apache/Reload.pod
===================================================================
RCS file: /home/cvs/modperl-docs/src/docs/2.0/api/Apache/Reload.pod,v
retrieving revision 1.10
diff -u -I$Id -r1.10 Reload.pod
--- docs/api/Apache/Reload.pod 22 May 2004 02:03:27 -0000 1.10
+++ docs/api/Apache/Reload.pod 8 Sep 2004 23:33:18 -0000
@@ -19,7 +19,6 @@
PerlSetVar ReloadAll Off
PerlSetVar ReloadModules "ModPerl::* Apache::*"
#PerlSetVar ReloadDebug On
- #PerlSetVar ReloadConstantRedefineWarnings Off
# Reload a single module from within itself:
package My::Apache::Module;
@@ -186,30 +185,6 @@
reloaded, are actually getting reloaded, turn the debug mode on:
PerlSetVar ReloadDebug On
-
-=head1 Silencing 'Constant subroutine ... redefined at' Warnings
-
-If a module defines constants, e.g.:
-
- use constant PI => 3.14;
-
-and gets re-loaded, Perl issues a mandatory warnings which can't be
-silenced by conventional means (since Perl 5.8.0). This is because
-constants are inlined at compile time, so if there are other modules
-that are using constants from this module, but weren't reloaded they
-will see different values. Hence the warning is mandatory. However
-chances are that most of the time you won't modify the constant
-subroutine and you don't want I<error_log> to be cluttered with
-(hopefully) irrelevant warnings. In such cases, if you haven't
-modified the constant subroutine, or you know what you are doing, you
-can tell C<Apache::Reload> to shut those for you (it overrides
-C<$SIG{__WARN__}> to accomplish that):
-
- PerlSetVar ReloadConstantRedefineWarnings Off
-
-For the reasons explained above this option is turned on by default.
-
-since: mod_perl 1.99_10
=head1 Caveats
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 8 Sep 2004 23:33:18 -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::unload_package($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 8 Sep 2004 23:33:18 -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_package_unload(aTHX_ pkg_name);
}
if (status != OK) {
Index: src/modules/perl/modperl_util.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_util.c,v
retrieving revision 1.77
diff -u -I$Id -r1.77 modperl_util.c
--- src/modules/perl/modperl_util.c 25 Aug 2004 20:57:14 -0000 1.77
+++ src/modules/perl/modperl_util.c 8 Sep 2004 23:33:18 -0000
@@ -300,6 +300,59 @@
free(handles);
}
+/* XXX: There is no XS accessible splice() */
+static void modperl_av_remove_entry(pTHX_ AV *av, I32 index)
+{
+ I32 i;
+ AV *tmpav = newAV();
+
+ /* stash the entries _before_ the item to delete */
+ for (i=0; i<=index; i++) {
+ av_store(tmpav, i, SvREFCNT_inc(av_shift(av)));
+ }
+
+ /* make size at the beginning of the array */
+ av_unshift(av, index-1);
+
+ /* add stashed entries back */
+ for (i=0; i<index; i++) {
+ av_store(av, i, *av_fetch(tmpav, i, 0));
+ }
+
+ SvREFCNT_dec(tmpav);
+}
+
+static void modperl_package_unload_dynamic(pTHX_ const char *package,
+ I32 dl_index)
+{
+ AV *librefs = get_av(dl_librefs, 0);
+ SV *libref = *av_fetch(librefs, dl_index, 0);
+
+ modperl_sys_dlclose((void *)SvIV(libref));
+
+ /* remove package from @dl_librefs and @dl_modules */
+ modperl_av_remove_entry(aTHX_ get_av(dl_librefs, 0), dl_index);
+ modperl_av_remove_entry(aTHX_ get_av(dl_modules, 0), dl_index);
+
+ return;
+}
+
+static int modperl_package_is_dynamic(pTHX_ const char *package,
+ I32 *dl_index)
+{
+ I32 i;
+ AV *modules = get_av(dl_modules, FALSE);
+
+ for (i=0; i<av_len(modules); i++) {
+ SV *module = *av_fetch(modules, i, 0);
+ if (strEQ(package, SvPVX(module))) {
+ *dl_index = i;
+ return TRUE;
+ }
+ }
+ return FALSE;
+}
+
modperl_cleanup_data_t *modperl_cleanup_data_new(apr_pool_t *p, void *data)
{
modperl_cleanup_data_t *cdata =
@@ -523,60 +576,6 @@
return (svp && *svp != &PL_sv_undef) ? 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); \
@@ -781,4 +780,46 @@
}
return array;
+}
+
+/* Remove a package from %INC */
+static void modperl_package_delete_from_inc(pTHX_ const char *package)
+{
+ int len;
+ char *filename = package2filename(package, &len);
+ hv_delete(GvHVn(PL_incgv), filename, len, G_DISCARD);
+ free(filename);
+}
+
+/* Destroy a package's stash */
+static void modperl_package_clear_stash(pTHX_ const char *package)
+{
+ HV *stash;
+ 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);
+ /* We skip entries ending with ::, they are sub-stashes */
+ if (len > 2 && key[len] != ':' && key[len-1] != ':') {
+ hv_delete(stash, key, len, G_DISCARD);
+ }
+ }
+ }
+}
+
+/* Unload a module as completely and cleanly as possible */
+void modperl_package_unload(pTHX_ const char *package)
+{
+ I32 dl_index;
+
+ modperl_package_clear_stash(aTHX_ package);
+ modperl_package_delete_from_inc(aTHX_ package);
+
+ if (modperl_package_is_dynamic(aTHX_ package, &dl_index)) {
+ modperl_package_unload_dynamic(aTHX_ package, dl_index);
+ }
+
}
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 8 Sep 2004 23:33:18 -0000
@@ -109,6 +109,7 @@
SV *modperl_apr_array_header2avrv(pTHX_ apr_array_header_t *array);
apr_array_header_t *modperl_avrv2apr_array_header(pTHX_ apr_pool_t *p,
SV *avrv);
+void modperl_package_unload(pTHX_ const char *package);
#if defined(MP_TRACE) && defined(APR_HAS_THREADS)
#define MP_TRACEf_TID "/tid 0x%lx"
#define MP_TRACEv_TID (unsigned long)apr_os_thread_current()
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 8 Sep 2004 23:33:18 -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: todo/features_optimization
===================================================================
RCS file: /home/cvs/modperl-2.0/todo/features_optimization,v
retrieving revision 1.3
diff -u -I$Id -r1.3 features_optimization
--- todo/features_optimization 4 Mar 2004 01:04:28 -0000 1.3
+++ todo/features_optimization 8 Sep 2004 23:33:18 -0000
@@ -15,3 +15,6 @@
* currently when ithreads-enabled perl is used anon-sub handlers are
always deparsed and non-cached. there are several cases when this
can be optimized. See modperl_handler_new_anon in modperl_handler.c
+
+* modperl_package_unload() and modperl_xs_dl_*() share some duplicated
+ logic. The managment of DynaLoaded modules could be somewhat cleaner.
Index: todo/release
===================================================================
RCS file: /home/cvs/modperl-2.0/todo/release,v
retrieving revision 1.54
diff -u -I$Id -r1.54 release
--- todo/release 25 Aug 2004 23:47:33 -0000 1.54
+++ todo/release 8 Sep 2004 23:33:18 -0000
@@ -100,10 +100,6 @@
not sure when. we need to ping him every so often. but
it'll probably won't happen by the time we release 2.0.
-* Apache::Reload
- - needs to handle properly redefined subs warnings
- owner: gozer
-
* Apache->unescape_url{_info}:
not yet implemented. should be moved to Apache::Util (or may be
APR::URI?)
Index: xs/ModPerl/Util/ModPerl__Util.h
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/ModPerl/Util/ModPerl__Util.h,v
retrieving revision 1.6
diff -u -I$Id -r1.6 ModPerl__Util.h
--- xs/ModPerl/Util/ModPerl__Util.h 25 Aug 2004 21:51:21 -0000 1.6
+++ xs/ModPerl/Util/ModPerl__Util.h 8 Sep 2004 23:33:18 -0000
@@ -29,5 +29,7 @@
#define mpxs_ModPerl__Util_current_callback \
modperl_callback_current_callback_get
+#define mpxs_ModPerl__Util_unload_package(pkg) \
+ modperl_package_unload(aTHX_ pkg)
Index: xs/maps/modperl_functions.map
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/maps/modperl_functions.map,v
retrieving revision 1.85
diff -u -I$Id -r1.85 modperl_functions.map
--- xs/maps/modperl_functions.map 25 Aug 2004 21:51:21 -0000 1.85
+++ xs/maps/modperl_functions.map 8 Sep 2004 23:33:18 -0000
@@ -7,6 +7,7 @@
mpxs_ModPerl__Util_untaint | | ...
DEFINE_exit | | int:status=0
char *:DEFINE_current_callback
+ DEFINE_unload_package | | const char *:package
MODULE=ModPerl::Global
mpxs_ModPerl__Global_special_list_call
Index: xs/tables/current/ModPerl/FunctionTable.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/tables/current/ModPerl/FunctionTable.pm,v
retrieving revision 1.177
diff -u -I$Id -r1.177 FunctionTable.pm
--- xs/tables/current/ModPerl/FunctionTable.pm 8 Sep 2004 00:42:02 -0000 1.177
+++ xs/tables/current/ModPerl/FunctionTable.pm 8 Sep 2004 23:33:18 -0000
@@ -2,7 +2,7 @@
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
# ! WARNING: generated by ModPerl::ParseSource/0.01
-# ! Mon Aug 30 22:40:23 2004
+# ! Wed Sep 8 15:12:22 2004
# ! do NOT edit, any changes will be lost !
# !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -3875,6 +3875,20 @@
{
'type' => 'apr_size_t *',
'name' => 'len'
+ }
+ ]
+ },
+ {
+ 'return_type' => 'void',
+ 'name' => 'modperl_package_unload',
+ 'args' => [
+ {
+ 'type' => 'PerlInterpreter *',
+ 'name' => 'my_perl'
+ },
+ {
+ 'type' => 'const char *',
+ 'name' => 'package'
}
]
},
signature.asc
Description: OpenPGP digital signature
