gozer 2004/09/09 15:16:38
Modified: . Changes
ModPerl-Registry/lib/ModPerl RegistryCooker.pm
lib/Apache Reload.pm
src/modules/perl modperl_cmd.c modperl_util.c modperl_util.h
t/response/TestModules reload.pm
todo features_optimization release
xs/ModPerl/Util ModPerl__Util.h
xs/maps modperl_functions.map
xs/tables/current/ModPerl FunctionTable.pm
Log:
Added ModPerl::Util::unload_package() to remove a loaded package
as thoroughly as possible by clearing it's stash.
Adjusted <Perl> sections, Apache::Reload and ModPerl::Registry to use
the new function.
Revision Changes Path
1.480 +3 -0 modperl-2.0/Changes
Index: Changes
===================================================================
RCS file: /home/cvs/modperl-2.0/Changes,v
retrieving revision 1.479
retrieving revision 1.480
diff -u -r1.479 -r1.480
--- Changes 9 Sep 2004 18:48:03 -0000 1.479
+++ Changes 9 Sep 2004 22:16:37 -0000 1.480
@@ -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 Apache->request($r) to be set-able even w/: PerlOptions
-GlobalRequest [Stas]
1.51 +1 -42 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.50
retrieving revision 1.51
diff -u -r1.50 -r1.51
--- RegistryCooker.pm 27 Jun 2004 21:26:45 -0000 1.50
+++ RegistryCooker.pm 9 Sep 2004 22:16:37 -0000 1.51
@@ -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});
}
1.16 +13 -31 modperl-2.0/lib/Apache/Reload.pm
Index: Reload.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/lib/Apache/Reload.pm,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -r1.15 -r1.16
--- Reload.pm 9 Sep 2004 18:29:09 -0000 1.15
+++ Reload.pm 9 Sep 2004 22:16:37 -0000 1.16
@@ -27,7 +27,9 @@
use Apache::ServerUtil;
use Apache::RequestUtil;
-use vars qw(%INCS %Stat $TouchTime %UndefFields);
+use ModPerl::Util ();
+
+use vars qw(%INCS %Stat $TouchTime);
%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";
- }
}
sub unregister_module {
@@ -116,15 +120,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";
- }
}
}
}
@@ -158,29 +153,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;
1.65 +1 -4 modperl-2.0/src/modules/perl/modperl_cmd.c
Index: modperl_cmd.c
===================================================================
RCS file: /home/cvs/modperl-2.0/src/modules/perl/modperl_cmd.c,v
retrieving revision 1.64
retrieving revision 1.65
diff -u -r1.64 -r1.65
--- modperl_cmd.c 23 Aug 2004 21:16:27 -0000 1.64
+++ modperl_cmd.c 9 Sep 2004 22:16:37 -0000 1.65
@@ -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) {
1.80 +95 -54 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.79
retrieving revision 1.80
diff -u -r1.79 -r1.80
--- modperl_util.c 9 Sep 2004 15:08:38 -0000 1.79
+++ modperl_util.c 9 Sep 2004 22:16:37 -0000 1.80
@@ -303,6 +303,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 =
@@ -526,60 +579,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); \
@@ -784,4 +783,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);
+ }
+
}
1.67 +1 -0 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.66
retrieving revision 1.67
diff -u -r1.66 -r1.67
--- modperl_util.h 22 Aug 2004 20:47:37 -0000 1.66
+++ modperl_util.h 9 Sep 2004 22:16:37 -0000 1.67
@@ -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()
1.4 +0 -1 modperl-2.0/t/response/TestModules/reload.pm
Index: reload.pm
===================================================================
RCS file: /home/cvs/modperl-2.0/t/response/TestModules/reload.pm,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- reload.pm 9 Sep 2004 18:29:09 -0000 1.3
+++ reload.pm 9 Sep 2004 22:16:38 -0000 1.4
@@ -29,5 +29,4 @@
PerlModule Apache::Reload
PerlInitHandler Apache::TestHandler::same_interp_fixup Apache::Reload
PerlSetVar ReloadDebug Off
-PerlSetVar ReloadConstantRedefineWarnings Off
PerlSetVar ReloadAll Off
1.4 +3 -0 modperl-2.0/todo/features_optimization
Index: features_optimization
===================================================================
RCS file: /home/cvs/modperl-2.0/todo/features_optimization,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- features_optimization 4 Mar 2004 01:04:28 -0000 1.3
+++ features_optimization 9 Sep 2004 22:16:38 -0000 1.4
@@ -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.
1.55 +0 -4 modperl-2.0/todo/release
Index: release
===================================================================
RCS file: /home/cvs/modperl-2.0/todo/release,v
retrieving revision 1.54
retrieving revision 1.55
diff -u -r1.54 -r1.55
--- release 25 Aug 2004 23:47:33 -0000 1.54
+++ release 9 Sep 2004 22:16:38 -0000 1.55
@@ -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?)
1.7 +2 -0 modperl-2.0/xs/ModPerl/Util/ModPerl__Util.h
Index: ModPerl__Util.h
===================================================================
RCS file: /home/cvs/modperl-2.0/xs/ModPerl/Util/ModPerl__Util.h,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- ModPerl__Util.h 25 Aug 2004 21:51:21 -0000 1.6
+++ ModPerl__Util.h 9 Sep 2004 22:16:38 -0000 1.7
@@ -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)
1.86 +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.85
retrieving revision 1.86
diff -u -r1.85 -r1.86
--- modperl_functions.map 25 Aug 2004 21:51:21 -0000 1.85
+++ modperl_functions.map 9 Sep 2004 22:16:38 -0000 1.86
@@ -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
1.178 +15 -1 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.177
retrieving revision 1.178
diff -u -r1.177 -r1.178
--- FunctionTable.pm 8 Sep 2004 00:42:02 -0000 1.177
+++ FunctionTable.pm 9 Sep 2004 22:16:38 -0000 1.178
@@ -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'
}
]
},
