Philippe M. Chiasson wrote:
Thanks for the code -- it looks excellent to me.Here is some code I've ripped from an in-house Apache::Reload equivalent... It's a bit convoluted, but does work quite nicely.
I've attached a patch for Apache::Reload that makes use of your code to achieve what I'm after. The patch is against the Apache::Reload currently in mp2 cvs. Things to note:
1. I've removed Apache::ServerUtil and Apache::RequestUtil -- they didn't seem to be being used.
2. I've removed the ConstantRedefineWarnings option because your code makes use of Apache::Symbol::undef() which avoids those warnings anyway.
3. I've removed the part of your code that skipped removing top-level packages -- I (perhaps unwisely) use such names a lot!
If this is going to be put into mp2 (which I certainly hope it is) then Apache::Symbol will need to be put back too since your code relies on it.
I've also attached a patch that will produce a mp1-compatible version of the same: Start with the current cvs mp2 Apache::Reload and apply the main patch to it, then apply the "for_mp1" patch to that.
I've quickly tested this mp1-compatible version, and it seems to be working so far: no "subroutine redefined" warnings are being produced (not even for constant subroutines), and imported subroutines are not being mistakenly undefined. I hope this can be added to mp1.28 (which already has Apache::Symbol, of course).
Steve
--- Reload.pm.orig 2003-06-17 08:37:04.000000000 +0100
+++ Reload.pm 2003-06-18 09:58:52.000000000 +0100
@@ -5,13 +5,14 @@
use mod_perl 1.99;
-our $VERSION = '0.09';
+our $VERSION = '0.10';
use Apache::Const -compile => qw(OK);
use Apache::Connection;
-use Apache::ServerUtil;
-use Apache::RequestUtil;
+use Apache::Symbol;
+use B;
+use Devel::Symdump;
use vars qw(%INCS %Stat $TouchTime %UndefFields);
@@ -63,9 +64,8 @@
my $TouchFile = ref($o) && $o->dir_config("ReloadTouchFile");
- my $ConstantRedefineWarnings = ref($o) &&
- (lc($o->dir_config("ReloadConstantRedefineWarnings") || '') eq 'off')
- ? 0 : 1;
+ my $RemovePackageOnReload = ref($o) &&
+ (lc($o->dir_config("RemovePackageOnReload") || '') eq 'on');
my $TouchModules;
@@ -144,9 +144,10 @@
no strict 'refs';
undef %{$symref};
}
- no warnings FATAL => 'all';
- local $SIG{__WARN__} = \&skip_redefine_const_sub_warn
- unless $ConstantRedefineWarnings;
+ if ($RemovePackageOnReload) {
+ my $pkg = Apache::Symbol::file2class($key);
+ remove_package($pkg);
+ }
require $key;
warn("Apache::Reload: process $$ reloading $key\n")
if $DEBUG;
@@ -157,9 +158,98 @@
return Apache::OK;
}
-sub skip_redefine_const_sub_warn {
- return if $_[0] =~ /^Constant subroutine [\w:]+ redefined at/;
- CORE::warn(@_);
+sub remove_package {
+ my $package = shift;
+ my $recursive = shift || 0;
+ my $create = $recursive ? 'rnew' : 'new';
+
+ my @removed;
+
+ if ($package eq __PACKAGE__ || $package =~ /^(B|Devel)::/) {
+ # suicide ? I don't think so...
+ # we do not attempt to reload ourselves, or B and Devel packages
+ return;
+ }
+
+ # should be a more safe way to figure it out than this
+ if ($package->can('bootstrap')) {
+ # XS/C code, very bad for now ! BAIL out
+ warn "$package contains non-perl code and can't be reloaded for now\n";
+ return;
+ }
+
+ my $stab = Devel::Symdump->$create($package);
+
+ my @methods = grep {$_ !~ /^(packages|ios|functions)$/}
+ sort keys %{$stab->{AUTOLOAD}};
+
+ for my $type ('packages', 'ios', @methods, 'functions') {
+ (my $dtype = uc $type) =~ s/E?S$//;
+
+ for (sort $stab->_partdump(uc $type)) {
+ s/([\000-\037\177])/ '^' . pack('c',ord($1) ^ 64)/eg;
+ next if /::SUPER(::.*)?$/;
+
+ if ($type eq 'scalars') {
+ no strict 'refs';
+ next unless defined $$_;
+ }
+ elsif ($type eq 'packages') {
+ next unless $recursive;
+ push @removed, remove_package($_, 'recursive');
+ }
+ elsif ($type eq 'functions') {
+ no strict 'refs';
+ my $stash = B::svref_2object(*$_{CODE})->GV->STASH->NAME;
+ # don't undef functions that are imported into this package
+ # from elsewhere
+ next if $stash ne $package;
+ }
+
+ no strict 'refs';
+ &{"undef_$dtype"} ($_) if defined &{"undef_$dtype"};
+ }
+ }
+
+ push @removed, $package;
+
+ my $filename = package_to_module($package);
+ delete $INC{$filename};
+
+# warn "UNLOADING OF $package COMPLETE\n";
+ return @removed;
+}
+
+sub undef_IO {
+ my $name = shift;
+ no strict 'refs';
+ # don't test if *$name is tied() first - see RT/perl ticket #9725
+ untie *$name;
+ close *$name;
+}
+
+sub undef_FUNCTION {
+ my $name = shift;
+ no strict 'refs';
+ Apache::Symbol::undef(*{$name}{CODE});
+}
+
+sub undef_SCALAR {
+ my $name = shift;
+ no strict 'refs';
+ undef $$name;
+}
+
+sub undef_ARRAY {
+ my $name = shift;
+ no strict 'refs';
+ undef $$name;
+}
+
+sub undef_HASH {
+ my $name = shift;
+ no strict 'refs';
+ undef $$name;
}
1;
--- Reload.pm 2003-06-18 09:58:52.000000000 +0100
+++ Reload.pm.mp1 2003-06-18 10:00:05.000000000 +0100
@@ -3,11 +3,9 @@
use strict;
use warnings FATAL => 'all';
-use mod_perl 1.99;
-
our $VERSION = '0.10';
-use Apache::Const -compile => qw(OK);
+use Apache::Constants qw(OK);
use Apache::Connection;
use Apache::Symbol;
@@ -155,7 +153,7 @@
$Stat{$file} = $mtime;
}
- return Apache::OK;
+ return OK;
}
sub remove_package {--------------------------------------------------------------------- To unsubscribe, e-mail: [EMAIL PROTECTED] For additional commands, e-mail: [EMAIL PROTECTED]
