home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / Reload.pm < prev    next >
Encoding:
Perl POD Document  |  2003-12-13  |  4.8 KB  |  168 lines
  1. package Apache::Reload;
  2.  
  3. use strict;
  4. use warnings FATAL => 'all';
  5.  
  6. use mod_perl 1.99;
  7.  
  8. our $VERSION = '0.09';
  9.  
  10. use Apache::Const -compile => qw(OK);
  11.  
  12. use Apache::Connection;
  13. use Apache::ServerUtil;
  14. use Apache::RequestUtil;
  15.  
  16. use vars qw(%INCS %Stat $TouchTime %UndefFields);
  17.  
  18. %Stat = ($INC{"Apache/Reload.pm"} => time);
  19.  
  20. $TouchTime = time;
  21.  
  22. sub import {
  23.     my $class = shift;
  24.     my($package,$file) = (caller)[0,1];
  25.  
  26.     $class->register_module($package, $file);
  27. }
  28.  
  29. sub package_to_module {
  30.     my $package = shift;
  31.     $package =~ s/::/\//g;
  32.     $package .= ".pm";
  33.     return $package;
  34. }
  35.  
  36. sub register_module {
  37.     my($class, $package, $file) = @_;
  38.     my $module = package_to_module($package);
  39.  
  40.     if ($file) {
  41.         $INCS{$module} = $file;
  42.     }
  43.     else {
  44.         $file = $INC{$module};
  45.         return unless $file;
  46.         $INCS{$module} = $file;
  47.     }
  48.  
  49.     no strict 'refs';
  50.     if (%{"${package}::FIELDS"}) {
  51.         $UndefFields{$module} = "${package}::FIELDS";
  52.     }
  53. }
  54.  
  55. # the first argument is:
  56. # $c if invoked as 'PerlPreConnectionHandler'
  57. # $r if invoked as 'PerlInitHandler'
  58. sub handler {
  59.     my $o = shift;
  60.     $o = $o->base_server if ref($o) eq 'Apache::Connection';
  61.  
  62.     my $DEBUG = ref($o) && (lc($o->dir_config("ReloadDebug") || '') eq 'on');
  63.  
  64.     my $TouchFile = ref($o) && $o->dir_config("ReloadTouchFile");
  65.  
  66.     my $ConstantRedefineWarnings = ref($o) && 
  67.         (lc($o->dir_config("ReloadConstantRedefineWarnings") || '') eq 'off') 
  68.             ? 0 : 1;
  69.  
  70.     my $TouchModules;
  71.  
  72.     if ($TouchFile) {
  73.         warn "Checking mtime of $TouchFile\n" if $DEBUG;
  74.         my $touch_mtime = (stat($TouchFile))[9] || return 1;
  75.         return 1 unless $touch_mtime > $TouchTime;
  76.         $TouchTime = $touch_mtime;
  77.         open my $fh, $TouchFile or die "Can't open '$TouchFile': $!";
  78.         $TouchModules = <$fh>;
  79.         chomp $TouchModules if $TouchModules;
  80.     }
  81.  
  82.     if (ref($o) && (lc($o->dir_config("ReloadAll") || 'on') eq 'on')) {
  83.         *Apache::Reload::INCS = \%INC;
  84.     }
  85.     else {
  86.         *Apache::Reload::INCS = \%INCS;
  87.         my $ExtraList = 
  88.                 $TouchModules || 
  89.                 (ref($o) && $o->dir_config("ReloadModules")) || 
  90.                 '';
  91.         my @extra = split(/\s+/, $ExtraList);
  92.         foreach (@extra) {
  93.             if (/(.*)::\*$/) {
  94.                 my $prefix = $1;
  95.                 $prefix =~ s/::/\//g;
  96.                 foreach my $match (keys %INC) {
  97.                     if ($match =~ /^\Q$prefix\E/) {
  98.                         $Apache::Reload::INCS{$match} = $INC{$match};
  99.                         my $package = $match;
  100.                         $package =~ s/\//::/g;
  101.                         $package =~ s/\.pm$//;
  102.                         no strict 'refs';
  103. #                        warn "checking for FIELDS on $package\n";
  104.                         if (%{"${package}::FIELDS"}) {
  105. #                            warn "found fields in $package\n";
  106.                             $UndefFields{$match} = "${package}::FIELDS";
  107.                         }
  108.                     }
  109.                 }
  110.             }
  111.             else {
  112.                 Apache::Reload->register_module($_);
  113.             }
  114.         }
  115.     }
  116.  
  117.     my $ReloadDirs = ref($o) && $o->dir_config("ReloadDirectories");
  118.     my @watch_dirs = split(/\s+/, $ReloadDirs||'');
  119.     while (my($key, $file) = each %Apache::Reload::INCS) {
  120.         next unless defined $file;
  121.         next if @watch_dirs && !grep { $file =~ /^$_/ } @watch_dirs;
  122.         warn "Apache::Reload: Checking mtime of $key\n" if $DEBUG;
  123.  
  124.         my $mtime = (stat $file)[9];
  125.  
  126.         unless (defined($mtime) && $mtime) {
  127.             for (@INC) {
  128.                 $mtime = (stat "$_/$file")[9];
  129.                 last if defined($mtime) && $mtime;
  130.             }
  131.         }
  132.  
  133.         warn("Apache::Reload: Can't locate $file\n"), next
  134.             unless defined $mtime and $mtime;
  135.  
  136.         unless (defined $Stat{$file}) {
  137.             $Stat{$file} = $^T;
  138.         }
  139.  
  140.         if ($mtime > $Stat{$file}) {
  141.             delete $INC{$key};
  142. #           warn "Reloading $key\n";
  143.             if (my $symref = $UndefFields{$key}) {
  144. #                warn "undeffing fields\n";
  145.                 no strict 'refs';
  146.                 undef %{$symref};
  147.             }
  148.             no warnings FATAL => 'all';
  149.             local $SIG{__WARN__} = \&skip_redefine_const_sub_warn
  150.                 unless $ConstantRedefineWarnings;
  151.             require $key;
  152.             warn("Apache::Reload: process $$ reloading $key\n")
  153.                     if $DEBUG;
  154.         }
  155.         $Stat{$file} = $mtime;
  156.     }
  157.  
  158.     return Apache::OK;
  159. }
  160.  
  161. sub skip_redefine_const_sub_warn {
  162.     return if $_[0] =~ /^Constant subroutine [\w:]+ redefined at/;
  163.     CORE::warn(@_);
  164. }
  165.  
  166. 1;
  167. __END__
  168.