registrycooker.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.
#
# VERY IMPORTANT: Be very careful modifying the defaults, since many
# VERY IMPORTANT: packages rely on them. In fact you should never
# VERY IMPORTANT: modify the defaults after the package gets released,
# VERY IMPORTANT: since they are a hardcoded part of this suite's API.

package ModPerl::RegistryCooker;

require 5.006;

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

our $VERSION = '1.99';

use Apache2::ServerUtil ();
use Apache2::Response ();
use Apache2::RequestRec ();
use Apache2::RequestUtil ();
use Apache2::RequestIO ();
use Apache2::Log ();
use Apache2::Access ();

use APR::Table ();
use APR::Status ();

use ModPerl::Util ();
use ModPerl::Global ();

use File::Spec::Functions ();
use File::Basename ();

use Apache2::Const -compile => qw(:common &OPT_EXECCGI);
use ModPerl::Const -compile => 'EXIT';

unless (defined $ModPerl::Registry::MarkLine) {
    $ModPerl::Registry::MarkLine = 1;
}

#########################################################################
# debug constants
#
#########################################################################
use constant D_NONE    => 0;
use constant D_ERROR   => 1;
use constant D_WARN    => 2;
use constant D_COMPILE => 4;
use constant D_NOISE   => 8;

# the debug level can be overriden on the main server level of
# httpd.conf with:
#   PerlSetVar ModPerl::RegistryCooker::DEBUG 4
use constant DEBUG => 0;
#XXX: below currently crashes the server on win32
#    defined Apache2->server->dir_config('ModPerl::RegistryCooker::DEBUG')
#        ? Apache2->server->dir_config('ModPerl::RegistryCooker::DEBUG')
#        : D_NONE;

#########################################################################
# OS specific constants
#
#########################################################################
use constant IS_WIN32 => $^O eq "MSWin32";

#########################################################################
# constant subs
#
#########################################################################
use constant NOP   => '';
use constant TRUE  => 1;
use constant FALSE => 0;


use constant NAMESPACE_ROOT => 'ModPerl::ROOT';


#########################################################################

unless (defined $ModPerl::RegistryCooker::NameWithVirtualHost) {
    $ModPerl::RegistryCooker::NameWithVirtualHost = 1;
}

#########################################################################
# func: new
# dflt: new
# args: $class - class to bless into
#       $r     - Apache2::RequestRec object
# desc: create the class's object and bless it
# rtrn: the newly created object
#########################################################################

sub new {
    my ($class, $r) = @_;
    my $self = bless {}, $class;
    $self->init($r);
    return $self;
}

#########################################################################
# func: init
# dflt: init
# desc: initializes the data object's fields: REQ FILENAME URI
# args: $r - Apache2::RequestRec object
# rtrn: nothing
#########################################################################

sub init {
    $_[0]->{REQ}      = $_[1];
    $_[0]->{URI}      = $_[1]->uri;
    $_[0]->{FILENAME} = $_[1]->filename;
}

#########################################################################
# func: handler
# dflt: handler
# desc: the handler() sub that is expected by Apache
# args: $class - handler's class
#       $r     - Apache2::RequestRec object
#       (o)can be called as handler($r) as well (without leading $class)
# rtrn: handler's response status
# note: must be implemented in a sub-class unless configured as
#       Apache2::Foo->handler in httpd.conf (because of the
#       __PACKAGE__, which is tied to the file)
#########################################################################

sub handler : method {
    my $class = (@_ >= 2) ? shift : __PACKAGE__;
    my $r = shift;
    return $class->new($r)->default_handler();
}

#########################################################################
# func: default_handler
# dflt: META: see above
# desc: META: see above
# args: $self - registry blessed object
# rtrn: handler's response status
# note: that's what most sub-class handlers will call
#########################################################################

sub default_handler {
    my $self = shift;

    $self->make_namespace;

    if ($self->should_compile) {
        my $rc = $self->can_compile;
        return $rc unless $rc == Apache2::Const::OK;
        $rc = $self->convert_script_to_compiled_handler;
        return $rc unless $rc == Apache2::Const::OK;
    }

    # handlers shouldn't set $r->status but return it, so we reset the
    # status after running it
    my $old_status = $self->{REQ}->status;
    my $rc = $self->run;
    my $new_status = $self->{REQ}->status($old_status);
    return ($rc == Apache2::Const::OK && $old_status != $new_status)
        ? $new_status
        : $rc;
}

#########################################################################
# func: run
# dflt: run
# desc: executes the compiled code
# args: $self - registry blessed object
# rtrn: execution status (Apache2::?)
#########################################################################

sub run {
    my $self = shift;

    my $r       = $self->{REQ};
    my $package = $self->{PACKAGE};

    $self->chdir_file;

    my $cv = \&{"$package\::handler"};

    my %orig_inc;
    if ($self->should_reset_inc_hash) {
        %orig_inc = %INC;
    }

    my $rc = Apache2::Const::OK;
    { # run the code and preserve warnings setup when it's done
        no warnings FATAL => 'all';
        #local $^W = 0;
        eval { $cv->($r, @_) };

        # log script's execution errors
        $rc = $self->error_check;

        {
            # there might be no END blocks to call, so $@ will be not
            # reset
            local $@;
            ModPerl::Global::special_list_call(END => $package);

            # log script's END blocks execution errors
            my $new_rc = $self->error_check;

            # use the END blocks return status if the script's execution
            # was successful
            $rc = $new_rc if $rc == Apache2::Const::OK;
        }

    }

    if ($self->should_reset_inc_hash) {
        # to avoid the bite of require'ing a file with no package delaration
        # Apache2::PerlRun in mod_perl 1.15_01 started to localize %INC
        # later on it has been adjusted to preserve loaded .pm files,
        # which presumably contained the package declaration
        for (keys %INC) {
            next if $orig_inc{$_};
            next if /\.pm$/;
            delete $INC{$_};
        }
    }

    $self->flush_namespace;

    $self->chdir_file(Apache2::ServerUtil::server_root());

    return $rc;
}



#########################################################################
# func: can_compile
# dflt: can_compile
# desc: checks whether the script is allowed and can be compiled
# args: $self - registry blessed object
# rtrn: $rc - return status to forward
# efct: initializes the data object's fields: MTIME
#########################################################################

sub can_compile {
    my $self = shift;
    my $r = $self->{REQ};

    return Apache2::Const::DECLINED if -d $r->my_finfo;

    $self->{MTIME} = -M _;

    if (!($r->allow_options & Apache2::Const::OPT_EXECCGI)) {
        $r->log_error("Options ExecCGI is off in this directory",
                       $self->{FILENAME});
        return Apache2::Const::FORBIDDEN;
    }

    $self->debug("can compile $self->{FILENAME}") if DEBUG & D_NOISE;

    return Apache2::Const::OK;

}
#########################################################################
# func: namespace_root
# dflt: namespace_root
# desc: define the namespace root for storing compiled scripts
# args: $self - registry blessed object
# rtrn: the namespace root
#########################################################################

sub namespace_root {
    my $self = shift;
    join '::', NAMESPACE_ROOT, ref($self);
}

#########################################################################
# func: make_namespace
# dflt: make_namespace
# desc: prepares the namespace
# args: $self - registry blessed object
# rtrn: the namespace
# efct: initializes the field: PACKAGE
#########################################################################

sub make_namespace {
    my $self = shift;

    my $package = $self->namespace_from;

    # Escape everything into valid perl identifiers
    $package =~ s/([^A-Za-z0-9_])/sprintf("_%2x", unpack("C", $1))/eg;

    # make sure that the sub-package doesn't start with a digit
    $package =~ s/^(\d)/_$1/;

    # prepend root
    $package = $self->namespace_root() . "::$package";

    $self->{PACKAGE} = $package;

    return $package;
}

#########################################################################
# func: namespace_from
# dflt: namespace_from_filename
# desc: returns a partial raw package name based on filename, uri, else
# args: $self - registry blessed object
# rtrn: a unique string
#########################################################################

*namespace_from = \&namespace_from_filename;

# return a package name based on $r->filename only
sub namespace_from_filename {
    my $self = shift;

    my ($volume, $dirs, $file) = 
        File::Spec::Functions::splitpath($self->{FILENAME});
    my @dirs = File::Spec::Functions::splitdir($dirs);
    return join '_', grep { defined && length } $volume, @dirs, $file;
}

# return a package name based on $r->uri only
sub namespace_from_uri {
    my $self = shift;

    my $path_info = $self->{REQ}->path_info;
    my $script_name = $path_info && $self->{URI} =~ /$path_info$/
        ? substr($self->{URI}, 0, length($self->{URI}) - length($path_info))
        : $self->{URI};

    if ($ModPerl::RegistryCooker::NameWithVirtualHost && 
        $self->{REQ}->server->is_virtual) {
        my $name = $self->{REQ}->get_server_name;
        $script_name = join "", $name, $script_name if $name;
    }

    $script_name =~ s:/+$:/__INDEX__:;

    return $script_name;
}

#########################################################################
# func: convert_script_to_compiled_handler
# dflt: convert_script_to_compiled_handler
# desc: reads the script, converts into a handler and compiles it
# args: $self - registry blessed object
# rtrn: success/failure status
#########################################################################

sub convert_script_to_compiled_handler {
    my $self = shift;

    my $rc = Apache2::Const::OK;

    $self->debug("Adding package $self->{PACKAGE}") if DEBUG & D_NOISE;

    # get the script's source
    $rc = $self->read_script;
    return $rc unless $rc == Apache2::Const::OK;

    # convert the shebang line opts into perl code
    my $shebang = $self->shebang_to_perl;

    # mod_cgi compat, should compile the code while in its dir, so
    # relative require/open will work.
    $self->chdir_file;

#    undef &{"$self->{PACKAGE}\::handler"}; unless DEBUG & D_NOISE; #avoid warnings
#    $self->{PACKAGE}->can('undef_functions') && $self->{PACKAGE}->undef_functions;

    my $line = $self->get_mark_line;

    $self->strip_end_data_segment;

    # handle the non-parsed handlers ala mod_cgi (though mod_cgi does
    # some tricks removing the header_out and other filters, here we
    # just call assbackwards which has the same effect).
    my $base = File::Basename::basename($self->{FILENAME});
    my $nph = substr($base, 0, 4) eq 'nph-' ? '$_[0]->assbackwards(1);' : "";
    my $script_name = $self->get_script_name || $0;

    my $eval = join '',
                    'package ',
                    $self->{PACKAGE}, ";",
                    "sub handler {",
                    "local \$0 = '$script_name';",
                    $nph,
                    $shebang,
                    $line,
                    ${ $self->{CODE} },
                    "\n}"; # last line comment without newline?

    $rc = $self->compile(\$eval);
    return $rc unless $rc == Apache2::Const::OK;
    $self->debug(qq{compiled package \"$self->{PACKAGE}\"}) if DEBUG & D_NOISE;

    $self->chdir_file(Apache2::ServerUtil::server_root());

#    if(my $opt = $r->dir_config("PerlRunOnce")) {
#        $r->child_terminate if lc($opt) eq "on";
#    }

    $self->cache_it;

    return $rc;
}

#########################################################################
# func: cache_table
# dflt: cache_table_common
# desc: return a symbol table for caching compiled scripts in
# args: $self - registry blessed object (or the class name)
# rtrn: symbol table
#########################################################################

*cache_table = \&cache_table_common;

sub cache_table_common {
    \%ModPerl::RegistryCache;
}


sub cache_table_local {
    my $self = shift;
    my $class = ref($self) || $self;
    no strict 'refs';
    \%$class;
}

#########################################################################
# func: cache_it
# dflt: cache_it
# desc: mark the package as cached by storing its modification time
# args: $self - registry blessed object
# rtrn: nothing
#########################################################################

sub cache_it {
    my $self = shift;
    $self->cache_table->{ $self->{PACKAGE} }{mtime} = $self->{MTIME};
}


#########################################################################
# func: is_cached
# dflt: is_cached
# desc: checks whether the package is already cached
# args: $self - registry blessed object
# rtrn: TRUE if cached,
#       FALSE otherwise
#########################################################################

sub is_cached {
    my $self = shift;
    exists $self->cache_table->{ $self->{PACKAGE} }{mtime};
}


#########################################################################
# func: should_compile
# dflt: should_compile_once
# desc: decide whether code should be compiled or not
# args: $self - registry blessed object
# rtrn: TRUE if should compile
#       FALSE otherwise
# efct: sets MTIME if it's not set yet
#########################################################################

*should_compile = \&should_compile_once;

# return false only if the package is cached and its source file
# wasn't modified
sub should_compile_if_modified {
    my $self = shift;
    $self->{MTIME} ||= -M $self->{REQ}->my_finfo;
    !($self->is_cached && 
      $self->cache_table->{ $self->{PACKAGE} }{mtime} <= $self->{MTIME});
}

# return false if the package is cached already
sub should_compile_once {
    not shift->is_cached;
}

#########################################################################
# func: should_reset_inc_hash
# dflt: FALSE
# desc: decide whether to localize %INC for required .pl files from the script
# args: $self - registry blessed object
# rtrn: TRUE if should reset
#       FALSE otherwise
#########################################################################

*should_reset_inc_hash = \&FALSE;

#########################################################################
# func: flush_namespace
# dflt: NOP (don't flush)
# desc: flush the compiled package's namespace
# args: $self - registry blessed object
# rtrn: nothing
#########################################################################

*flush_namespace = \&NOP;

sub flush_namespace_normal {
    my $self = shift;

    $self->debug("flushing namespace") if DEBUG & D_NOISE;
    ModPerl::Util::unload_package($self->{PACKAGE});
}


#########################################################################
# func: read_script
# dflt: read_script