reload.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

# Copyright 2001-2005 The Apache Software Foundation
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
#
package Apache2::Reload;

use strict;
use warnings FATAL => 'all';

use mod_perl2;

our $VERSION = '0.09';

use Apache2::Const -compile => qw(OK);

use Apache2::Connection;
use Apache2::ServerUtil;
use Apache2::RequestUtil;

use ModPerl::Util ();

use vars qw(%INCS %Stat $TouchTime);

%Stat = ($INC{"Apache2/Reload.pm"} => time);

$TouchTime = time;

sub import {
    my $class = shift;
    my ($package, $file) = (caller)[0,1];

    $class->register_module($package, $file);
}

sub package_to_module {
    my $package = shift;
    $package =~ s/::/\//g;
    $package .= ".pm";
    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);

    if ($file) {
        $INCS{$module} = $file;
    }
    else {
        $file = $INC{$module};
        return unless $file;
        $INCS{$module} = $file;
    }
}

sub unregister_module {
    my ($class, $package) = @_;
    my $module = package_to_module($package);
    delete $INCS{$module};
}

# the first argument is:
# $c if invoked as 'PerlPreConnectionHandler'
# $r if invoked as 'PerlInitHandler'
sub handler {
    my $o = shift;
    $o = $o->base_server if ref($o) eq 'Apache2::Connection';

    my $DEBUG = ref($o) && (lc($o->dir_config("ReloadDebug") || '') eq 'on');

    my $TouchFile = ref($o) && $o->dir_config("ReloadTouchFile");

    my $ConstantRedefineWarnings = ref($o) && 
        (lc($o->dir_config("ReloadConstantRedefineWarnings") || '') eq 'off') 
            ? 0 : 1;

    my $TouchModules;

    if ($TouchFile) {
        warn "Checking mtime of $TouchFile\n" if $DEBUG;
        my $touch_mtime = (stat $TouchFile)[9] || return Apache2::Const::OK;
        return Apache2::Const::OK unless $touch_mtime > $TouchTime;
        $TouchTime = $touch_mtime;
        open my $fh, $TouchFile or die "Can't open '$TouchFile': $!";
        $TouchModules = <$fh>;
        chomp $TouchModules if $TouchModules;
    }

    if (ref($o) && (lc($o->dir_config("ReloadAll") || 'on') eq 'on')) {
        *Apache2::Reload::INCS = \%INC;
    }
    else {
        *Apache2::Reload::INCS = \%INCS;
        my $ExtraList = 
                $TouchModules || 
                (ref($o) && $o->dir_config("ReloadModules")) || 
                '';
        my @extra = split /\s+/, $ExtraList;
        foreach (@extra) {
            if (/(.*)::\*$/) {
                my $prefix = $1;
                $prefix =~ s/::/\//g;
                foreach my $match (keys %INC) {
                    if ($match =~ /^\Q$prefix\E/) {
                        $Apache2::Reload::INCS{$match} = $INC{$match};
                    }
                }
            }
            else {
                Apache2::Reload->register_module($_);
            }
        }
    }

    my $ReloadDirs = ref($o) && $o->dir_config("ReloadDirectories");
    my @watch_dirs = split(/\s+/, $ReloadDirs||'');
    foreach my $key (sort { $a cmp $b } keys %Apache2::Reload::INCS) {
        my $file = $Apache2::Reload::INCS{$key};

        next unless defined $file;
        next if @watch_dirs && !grep { $file =~ /^$_/ } @watch_dirs;
        warn "Apache2::Reload: Checking mtime of $key\n" if $DEBUG;

        my $mtime = (stat $file)[9];

        unless (defined($mtime) && $mtime) {
            for (@INC) {
                $mtime = (stat "$_/$file")[9];
                last if defined($mtime) && $mtime;
            }
        }

        warn("Apache2::Reload: Can't locate $file\n"), next
            unless defined $mtime and $mtime;

        unless (defined $Stat{$file}) {
            $Stat{$file} = $^T;
        }

        if ($mtime > $Stat{$file}) {
            my $package = module_to_package($key);
            ModPerl::Util::unload_package($package);
            require $key;
            warn("Apache2::Reload: process $$ reloading $package from $key\n")
                    if $DEBUG;
        }
        $Stat{$file} = $mtime;
    }

    return Apache2::Const::OK;
}

1;
__END__

=head1 NAME

Apache2::Reload - Reload Perl Modules when Changed on Disk

=head1 Synopsis

  # Monitor and reload all modules in %INC:
  # httpd.conf:
  PerlModule Apache2::Reload
  PerlInitHandler Apache2::Reload

  # when working with protocols and connection filters
  # PerlPreConnectionHandler Apache2::Reload

  # Reload groups of modules:
  # httpd.conf:
  PerlModule Apache2::Reload
  PerlInitHandler Apache2::Reload
  PerlSetVar ReloadAll Off
  PerlSetVar ReloadModules "ModPerl::* Apache2::*"
  #PerlSetVar ReloadDebug On
  
  # Reload a single module from within itself:
  package My::Apache2::Module;
  use Apache2::Reload;
  sub handler { ... }
  1;

=head1 Description

C<Apache2::Reload> reloads modules that change on the disk.

When Perl pulls a file via C<require>, it stores the filename in the
global hash C<%INC>.  The next time Perl tries to C<require> the same
file, it sees the file in C<%INC> and does not reload from disk.  This
module's handler can be configured to iterate over the modules in
C<%INC> and reload those that have changed on disk or only specific
modules that have registered themselves with C<Apache2::Reload>. It can
also do the check for modified modules, when a special touch-file has
been modified.

Note that C<Apache2::Reload> operates on the current context of
C<@INC>.  Which means, when called as a C<Perl*Handler> it will not
see C<@INC> paths added or removed by C<ModPerl::Registry> scripts, as
the value of C<@INC> is saved on server startup and restored to that
value after each request.  In other words, if you want
C<Apache2::Reload> to work with modules that live in custom C<@INC>
paths, you should modify C<@INC> when the server is started.  Besides,
C<'use lib'> in the startup script, you can also set the C<PERL5LIB>
variable in the httpd's environment to include any non-standard 'lib'
directories that you choose.  For example, to accomplish that you can
include a line:

  PERL5LIB=/home/httpd/perl/extra; export PERL5LIB

in the script that starts Apache. Alternatively, you can set this
environment variable in I<httpd.conf>:

  PerlSetEnv PERL5LIB /home/httpd/perl/extra

=head2 Monitor All Modules in C<%INC>

To monitor and reload all modules in C<%INC> at the beginning of
request's processing, simply add the following configuration to your
I<httpd.conf>:

  PerlModule Apache2::Reload
  PerlInitHandler Apache2::Reload

When working with connection filters and protocol modules
C<Apache2::Reload> should be invoked in the pre_connection stage:

  PerlPreConnectionHandler Apache2::Reload

See also the discussion on
C<L<PerlPreConnectionHandler|docs::2.0::user::handlers::protocols/PerlPreConnectionHandler>>.

=head2 Register Modules Implicitly

To only reload modules that have registered with C<Apache2::Reload>,
add the following to the I<httpd.conf>:

  PerlModule Apache2::Reload
  PerlInitHandler Apache2::Reload
  PerlSetVar ReloadAll Off
  # ReloadAll defaults to On

Then any modules with the line:

  use Apache2::Reload;

Will be reloaded when they change.

=head2 Register Modules Explicitly

You can also register modules explicitly in your I<httpd.conf> file
that you want to be reloaded on change:

  PerlModule Apache2::Reload
  PerlInitHandler Apache2::Reload
  PerlSetVar ReloadAll Off
  PerlSetVar ReloadModules "My::Foo My::Bar Foo::Bar::Test"

Note that these are split on whitespace, but the module list B<must>
be in quotes, otherwise Apache tries to parse the parameter list.