Philippe M. Chiasson wrote:
On Wed, 2003-06-18 at 17:19, Steve Hay wrote:Done. Attached.
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:
[snip]
Can you instead look at this patch: http://marc.theaimsgroup.com/?l=apache-modperl-dev&m=105591352209314&w=2
And integrate that into an mod_perl 1 & 2 Apache::Reload instead? I would rather not have to maintain 2 ever so slightly different versions of Apache::Reload if that can be avoided.
I had to alter the patch that you cited above very slightly: it defers the import of the OK constant until run-time, which made it choke on the bareword OK (since its running under "use strict"). I've therefore pushed the mp1/mp2 conditional stuff inside a BEGIN {} block.
I've also added a couple of extra lines to conditionally setup an undef_func() -- under mp1 it is just Apache::Symbol::undef, under mp2 it will be ModPerl::Util::undef which you suggested in the rest of your mail (below).
The only other thing that I was using from Apache::Symbol was the file2class() function. I've now included that in Apache::Reload itself as module_to_package(), complementing the package_to_module() that it already had.
So there is no need to put Apache::Symbol back into mp2 -- just copy its undef() to ModPerl::Util as you suggested, and hopefully this Apache::Reload will work with mp1 and mp2.
I've re-tested it under mp1 and it still looks OK. I don't have an mp2 system to try out, though.
Steve
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).
Just might ;-)
I guess Apache::Symbol might need to be re-created for mp2. According to : $> fgrep Apache::Symbpl mp2/docs/deprecated_features.txt + Apache::Symbol: unknown
There are only 3 functions in there, and they are: undef sv_name cv_const_sv
I don't see why we can't find some room for those somewhere in mp2, especially the magical 'undef' function in there.
Stas: BTW, for Apache::Reload, to get rid of that constant subroutine redefined, that XS implemtation would get rid of it without a need for skip_redefine_const_sub_warn. No more $SIG{__WARN__} ;-)
How about if I ported Apache::Symbol::undef to ModPerl::Util::undef ?
Gozer out to bed.
--- Reload.pm.orig 2003-06-17 08:37:04.000000000 +0100
+++ Reload.pm 2003-06-18 17:39:26.000000000 +0100
@@ -3,15 +3,32 @@
use strict;
use warnings FATAL => 'all';
-use mod_perl 1.99;
+use mod_perl;
-our $VERSION = '0.09';
+our $VERSION = '0.10';
-use Apache::Const -compile => qw(OK);
+BEGIN {
+ use constant MOD_PERL2 => $mod_perl::VERSION >= 1.99;
-use Apache::Connection;
-use Apache::ServerUtil;
-use Apache::RequestUtil;
+ if (MOD_PERL2) {
+ require Apache::Const;
+ Apache::Const->import(qw(OK));
+ require Apache::Connection;
+ require Apache::ServerUtil;
+ require Apache::RequestUtil;
+ require ModPerl::Util;
+ *undef_func = \&ModPerl::Util::undef;
+ }
+ else {
+ require Apache::Constants;
+ Apache::Constants->import(qw(OK));
+ require Apache::Symbol;
+ *undef_func = \&Apache::Symbol::undef;
+ }
+}
+
+use B;
+use Devel::Symdump;
use vars qw(%INCS %Stat $TouchTime %UndefFields);
@@ -33,6 +50,13 @@
return $package;
}
+sub module_to_package {
+ my $module = shift;
+ $module =~ s/\.pm$//;
+ $module =~ s/\//::/g;
+ return $module;
+}
+
sub register_module {
my($class, $package, $file) = @_;
my $module = package_to_module($package);
@@ -63,9 +87,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 +167,10 @@
no strict 'refs';
undef %{$symref};
}
- no warnings FATAL => 'all';
- local $SIG{__WARN__} = \&skip_redefine_const_sub_warn
- unless $ConstantRedefineWarnings;
+ if ($RemovePackageOnReload) {
+ my $pkg = module_to_package($key);
+ remove_package($pkg);
+ }
require $key;
warn("Apache::Reload: process $$ reloading $key\n")
if $DEBUG;
@@ -154,12 +178,101 @@
$Stat{$file} = $mtime;
}
- return Apache::OK;
+ return OK;
+}
+
+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 skip_redefine_const_sub_warn {
- return if $_[0] =~ /^Constant subroutine [\w:]+ redefined at/;
- CORE::warn(@_);
+sub undef_FUNCTION {
+ my $name = shift;
+ no strict 'refs';
+ undef_func(*{$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;--------------------------------------------------------------------- To unsubscribe, e-mail: [EMAIL PROTECTED] For additional commands, e-mail: [EMAIL PROTECTED]
