"Fossies" - the Fresh Open Source Software Archive

Member "mod_perl-2.0.11/Apache-Reload/lib/Apache/Reload.pm" (5 Oct 2019, 8461 Bytes) of package /linux/www/apache_httpd_modules/mod_perl-2.0.11.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "Reload.pm" see the Fossies "Dox" file reference documentation and the last Fossies "Diffs" side-by-side code changes report: 2.0.8_vs_2.0.9.

    1 # Licensed to the Apache Software Foundation (ASF) under one or more
    2 # contributor license agreements.  See the NOTICE file distributed with
    3 # this work for additional information regarding copyright ownership.
    4 # The ASF licenses this file to You under the Apache License, Version 2.0
    5 # (the "License"); you may not use this file except in compliance with
    6 # the License.  You may obtain a copy of the License at
    7 #
    8 #     http://www.apache.org/licenses/LICENSE-2.0
    9 #
   10 # Unless required by applicable law or agreed to in writing, software
   11 # distributed under the License is distributed on an "AS IS" BASIS,
   12 # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
   13 # See the License for the specific language governing permissions and
   14 # limitations under the License.
   15 
   16 package Apache::Reload;
   17 
   18 use strict;
   19 
   20 $Apache::Reload::VERSION = '0.13';
   21 
   22 use vars qw(%INCS %Stat $TouchTime %UndefFields %Ignore);
   23 
   24 %Stat = ($INC{"Apache/Reload.pm"} => time);
   25 
   26 $TouchTime = time;
   27 
   28 sub import {
   29     my $class = shift;
   30     my ($package,$file) = (caller)[0,1];
   31     
   32     $class->register_module($package, $file);
   33 }
   34 
   35 sub unimport {
   36     my $class = shift;
   37     my ($package,$file) = (caller)[0,1];
   38 
   39     $class->unregister_module($package, $file);
   40 }
   41 
   42 sub package_to_module {
   43     my $package = shift;
   44     $package =~ s/::/\//g;
   45     $package .= ".pm";
   46     return $package;
   47 }
   48 
   49 sub register_module {
   50     my ($class, $package, $file) = @_;
   51     my $module = package_to_module($package);
   52     
   53     if ($file) {
   54         $INCS{$module} = $file;
   55     }
   56     else {
   57         $file = $INC{$module};
   58         return unless $file;
   59         $INCS{$module} = $file;
   60     }
   61     
   62     no strict 'refs';
   63     if (%{"${package}::FIELDS"}) {
   64         $UndefFields{$module} = "${package}::FIELDS";
   65     }
   66 }
   67 
   68 sub unregister_module {
   69     my ($class, $package, $file) = @_;
   70     my $module = package_to_module($package);
   71 
   72     $Ignore{$module} = 1;
   73 }
   74 
   75 sub handler {
   76     my $r = shift;
   77     
   78     my $DEBUG = ref($r) && (lc($r->dir_config("ReloadDebug") || '') eq 'on');
   79     
   80     my $TouchFile = ref($r) && $r->dir_config("ReloadTouchFile");
   81     
   82     my $TouchModules;
   83     
   84     if ($TouchFile) {
   85         warn "Checking mtime of $TouchFile\n" if $DEBUG;
   86         my $touch_mtime = (stat($TouchFile))[9] || return 1;
   87         return 1 unless $touch_mtime > $TouchTime;
   88         $TouchTime = $touch_mtime;
   89         my $sym = Apache->gensym;
   90         open($sym, $TouchFile) || die "Can't open '$TouchFile': $!";
   91         $TouchModules = <$sym>;
   92         chomp $TouchModules;
   93     }
   94     
   95     if (ref($r) && (lc($r->dir_config("ReloadAll") || 'on') eq 'on')) {
   96         *Apache::Reload::INCS = \%INC;
   97     }
   98     else {
   99         *Apache::Reload::INCS = \%INCS;
  100         my $ExtraList = 
  101                 $TouchModules || 
  102                 (ref($r) && $r->dir_config("ReloadModules")) || 
  103                 '';
  104         my @extra = split(/\s+/, $ExtraList);
  105         foreach (@extra) {
  106             if (/(.*)::\*$/) {
  107                 my $prefix = $1;
  108                 $prefix =~ s/::/\//g;
  109                 foreach my $match (keys %INC) {
  110                     if ($match =~ /^\Q$prefix\E/) {
  111                         $Apache::Reload::INCS{$match} = $INC{$match};
  112                         my $package = $match;
  113                         $package =~ s/\//::/g;
  114                         $package =~ s/\.pm$//;
  115                         no strict 'refs';
  116 #                        warn "checking for FIELDS on $package\n";
  117                         if (%{"${package}::FIELDS"}) {
  118 #                            warn "found fields in $package\n";
  119                             $UndefFields{$match} = "${package}::FIELDS";
  120                         }
  121                     }
  122                 }
  123             }
  124             else {
  125                 Apache::Reload->register_module($_);
  126             }
  127         }
  128     }
  129     
  130     my @changed;
  131     while (my($key, $file) = each %Apache::Reload::INCS) {
  132         local $^W;
  133         warn "Apache::Reload: Checking mtime of $key\n" if $DEBUG;
  134         
  135         my $mtime = (stat $file)[9];
  136 
  137         unless (defined($mtime) && $mtime) {
  138             for (@INC) {
  139                 $mtime = (stat "$_/$file")[9];
  140                 last if defined($mtime) && $mtime;
  141             }
  142         }
  143 
  144         warn("Apache::Reload: Can't locate $file\n"),next 
  145                 unless defined $mtime and $mtime;
  146         
  147         unless (defined $Stat{$file}) {
  148             $Stat{$file} = $^T;
  149         }
  150         # remove the modules
  151         if ($mtime > $Stat{$file}) {
  152             if ($Ignore{$key}) {
  153                 warn "Apache::Reload: Not reloading $key\n";
  154             }
  155             else {
  156                 delete $INC{$key};
  157                 push @changed, $key;
  158             }
  159         }
  160         $Stat{$file} = $mtime;
  161     }
  162 
  163     # reload the modules
  164     foreach my $key (@changed) {
  165         warn("Reloading $key\n") if $DEBUG;
  166         if (my $symref = $UndefFields{$key}) {
  167             warn("undeffing fields\n") if $DEBUG;
  168             no strict 'refs';
  169             undef %{$symref};
  170         }
  171         require $key;
  172         warn("Apache::Reload: process $$ reloading $key\n")
  173             if $DEBUG;
  174     }
  175 
  176     return 1;
  177 }
  178 
  179 1;
  180 __END__
  181 
  182 =head1 NAME
  183 
  184 Apache::Reload - Reload changed modules
  185 
  186 =head1 SYNOPSIS
  187 
  188 In httpd.conf:
  189 
  190   PerlInitHandler Apache::Reload
  191   PerlSetVar ReloadAll Off
  192 
  193 Then your module:
  194 
  195   package My::Apache::Module;
  196 
  197   use Apache::Reload;
  198   
  199   sub handler { ... }
  200   
  201   1;
  202 
  203 =head1 DESCRIPTION
  204 
  205 This module is two things. First it is an adaptation of Randal
  206 Schwartz's Stonehenge::Reload module that attempts to be a little 
  207 more intuitive and makes the usage easier. Stonehenge::Reload was
  208 written by Randal to make specific modules reload themselves when
  209 they changed. Unlike Apache::StatINC, Stonehenge::Reload only checked
  210 the change time of modules that registered themselves with 
  211 Stonehenge::Reload, thus reducing stat() calls. Apache::Reload also
  212 offers the exact same functionality as Apache::StatINC, and is thus
  213 designed to be a drop-in replacement. Apache::Reload only checks modules
  214 that register themselves with Apache::Reload if you explicitly turn off
  215 the StatINC emulation method (see below). Like Apache::StatINC,
  216 Apache::Reload must be installed as an Init Handler.
  217 
  218 =head2 StatINC Replacement
  219 
  220 To use as a StatINC replacement, simply add the following configuration
  221 to your httpd.conf:
  222 
  223   PerlInitHandler Apache::Reload
  224 
  225 =head2 Register Modules Implicitly
  226 
  227 To only reload modules that have registered with Apache::Reload,
  228 add the following to the httpd.conf:
  229 
  230   PerlInitHandler Apache::Reload
  231   PerlSetVar ReloadAll Off
  232   # ReloadAll defaults to On
  233 
  234 Then any modules with the line:
  235 
  236   use Apache::Reload;
  237 
  238 Will be reloaded when they change.
  239 
  240 =head2 Register Modules Explicitly
  241 
  242 You can also register modules explicitly in your httpd.conf file that
  243 you want to be reloaded on change:
  244 
  245   PerlInitHandler Apache::Reload
  246   PerlSetVar ReloadAll Off
  247   PerlSetVar ReloadModules "My::Foo My::Bar Foo::Bar::Test"
  248 
  249 Note that these are split on whitespace, but the module list B<must>
  250 be in quotes, otherwise Apache tries to parse the parameter list.
  251 
  252 =head2 Un-Register Modules Explicitly
  253 
  254 If ReloadAll is set to On, then you can explicity force a module not to be reloaded with
  255 
  256   no Apache::Reload;
  257 
  258 A warning will appear in the error log that the file has changed, but will
  259 not be reloaded
  260 
  261 =head2 Special "Touch" File
  262 
  263 You can also set a file that you can touch() that causes the reloads to be
  264 performed. If you set this, and don't touch() the file, the reloads don't
  265 happen. This can be a great boon in a live environment:
  266 
  267   PerlSetVar ReloadTouchFile /tmp/reload_modules
  268 
  269 Now when you're happy with your changes, simply go to the command line and
  270 type:
  271 
  272   touch /tmp/reload_modules
  273 
  274 And your modules will be magically reloaded on the next request. This option
  275 works in both StatINC emulation mode and the registered modules mode.
  276 
  277 =head1 PSUEDOHASHES
  278 
  279 The short summary of this is: Don't use psuedohashes. Use an array with
  280 constant indexes. Its faster in the general case, its more guaranteed, and
  281 generally, it works.
  282 
  283 The long summary is that I've done some work to get this working with
  284 modules that use psuedo hashes, but its still broken in the case of a
  285 single module that contains multiple packages that all use psuedohashes.
  286 
  287 So don't do that.
  288 
  289 =head1 AUTHOR
  290 
  291 Matt Sergeant, matt@sergeant.org
  292 
  293 =head1 MAINTAINERS
  294 
  295 the mod_perl developers, dev@perl.apache.org
  296 
  297 =head1 SEE ALSO
  298 
  299 Apache::StatINC, Stonehenge::Reload
  300 
  301 =cut