testconfigperl.pm

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

# Copyright 2001-2005 The Apache Software Foundation or its licensors, as
# applicable.
#
# 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 Apache::TestConfig; #not TestConfigPerl on purpose

#things specific to mod_perl

use strict;
use warnings FATAL => 'all';
use File::Spec::Functions qw(catfile splitdir abs2rel file_name_is_absolute);
use File::Find qw(finddepth);
use Apache::TestTrace;
use Apache::TestRequest;
use Config;

my %libmodperl  = (1 => 'libperl.so', 2 => 'mod_perl.so');

sub configure_libmodperl {
    my $self = shift;

    my $server  = $self->{server};
    my $libname = $server->version_of(\%libmodperl);
    my $vars = $self->{vars};

    if ($vars->{libmodperl}) {
        # if set, libmodperl was specified from the command line and
        # should be used instead of the one that is looked up

        # resolve a non-absolute path
        $vars->{libmodperl} = $self->find_apache_module($vars->{libmodperl})
            unless file_name_is_absolute($vars->{libmodperl});
    }
    # $server->{rev} could be set to 2 as a fallback, even when
    # the wanted version is 1. So check that we use mod_perl 2
    elsif ($server->{rev} >= 2 && IS_MOD_PERL_2) {
        if (my $build_config = $self->modperl_build_config()) {
            if ($build_config->{MODPERL_LIB_SHARED}) {
                $libname = $build_config->{MODPERL_LIB_SHARED};
                $vars->{libmodperl} ||= $self->find_apache_module($libname);
            }
            # XXX: we have a problem with several perl trees pointing
            # to the same httpd tree. So it's possible that we
            # configure the test suite to run with mod_perl.so built
            # against perl which it wasn't built with. Should we use
            # something like ldd to check the match?
        }
        else {
            # XXX: can we test whether mod_perl was linked statically
            # so we don't need to preload it
            # if (!linked statically) {
            #     die "can't find mod_perl built for perl version $]"
            # }
            error "can't find mod_perl.so built for perl version $]";
        }
        # don't use find_apache_module or we may end up with the wrong
        # shared object, built against different perl
    }
    else {
        # mod_perl 1.0
        $vars->{libmodperl} ||= $self->find_apache_module($libname);
        # XXX: how do we find out whether we have a static or dynamic
        # mod_perl build? die if its dynamic and can't find the module
    }

    my $cfg = '';

    if ($vars->{libmodperl} && -e $vars->{libmodperl}) {
        if (Apache::TestConfig::WIN32) {
            my $lib = "$Config{installbin}\\$Config{libperl}";
            $lib =~ s/lib$/dll/;
            $cfg = 'LoadFile ' . qq("$lib"\n) if -e $lib;
	}
        # add the module we found to the cached modules list
        # otherwise have_module('mod_perl') doesn't work unless
        # we have a LoadModule in our base config
        $self->{modules}->{'mod_perl.c'} = $vars->{libmodperl};

        $cfg .= 'LoadModule ' . qq(perl_module "$vars->{libmodperl}"\n);
    }
    else {
        my $msg = "unable to locate $libname (could be a static build)\n";
        $cfg = "#$msg";
        debug $msg;
    }

    $self->preamble(IfModule => '!mod_perl.c', $cfg);

}

sub configure_inc {
    my $self = shift;

    my $top = $self->{vars}->{top_dir};

    my $inc = $self->{inc};
    my @trys = (catdir($top, qw(blib lib)),
                catdir($top, qw(blib arch)));

    for (@trys) {
        push @$inc, $_ if -d $_;
    }

    # spec: If PERL5LIB is defined, PERLLIB is not used.
    for (qw(PERL5LIB PERLLIB)) {
        next unless exists $ENV{$_};
        push @$inc, split /$Config{path_sep}/, $ENV{$_};
        last;
    }

    # enable live testing of the Apache-Test dev modules if they are
    # located at the project's root dir
    my $apache_test_dev_dir = catfile($top, 'Apache-Test', 'lib');
    unshift @$inc, $apache_test_dev_dir if -d $apache_test_dev_dir;
}

sub write_pm_test {
    my($self, $module, $sub, @base) = @_;

    my $dir = catfile $self->{vars}->{t_dir}, @base;
    my $t = catfile $dir, "$sub.t";
    return if -e $t;

    $self->gendir($dir);
    my $fh = $self->genfile($t);

    my $path = Apache::TestRequest::module2path($module);

    print $fh <<EOF;
use Apache::TestRequest 'GET_BODY_ASSERT';
print GET_BODY_ASSERT "/$path";
EOF

    close $fh or die "close $t: $!";
}

# propogate trace overrides to the server
sub configure_trace {
    my $self = shift;
    $self->postamble(IfModule => 'mod_perl.c',
                     "PerlPassEnv APACHE_TEST_TRACE_LEVEL\n");
}

sub startup_pl_code {
    my $self = shift;
    my $serverroot = $self->{vars}->{serverroot};

    return <<"EOF";
BEGIN {
    use lib '$serverroot';
    for my \$file (qw(modperl_inc.pl modperl_extra.pl)) {
        eval { require "conf/\$file" } or
            die if grep { -e "\$_/conf/\$file" } \@INC;
    }
}

1;
EOF
}

sub configure_startup_pl {
    my $self = shift;

    #for 2.0 we could just use PerlSwitches -Mlib=...
    #but this will work for both 2.0 and 1.xx
    if (my $inc = $self->{inc}) {
        my $include_pl = catfile $self->{vars}->{t_conf}, 'modperl_inc.pl';
        my $fh = $self->genfile($include_pl);
        for (reverse @$inc) {
            next unless $_;
            print $fh "use lib '$_';\n";
        }
        my $tlib = catdir $self->{vars}->{t_dir}, 'lib';
        if (-d $tlib) {
            print $fh "use lib '$tlib';\n";
        }

        # if Apache::Test is used to develop a project, we want the
        # project/lib directory to be first in @INC (loaded last)
        if ($ENV{APACHE_TEST_LIVE_DEV}) {
            my $dev_lib = catdir $self->{vars}->{top_dir}, "lib";
            print $fh "use lib '$dev_lib';\n" if -d $dev_lib;
        }

        print $fh "1;\n";
    }

    if ($self->server->{rev} >= 2) {
        $self->postamble(IfModule => 'mod_perl.c',
                         "PerlSwitches -Mlib=$self->{vars}->{serverroot}\n");
    }

    my $startup_pl = catfile $self->{vars}->{t_conf}, 'modperl_startup.pl';

    unless (-e $startup_pl) {
        my $fh = $self->genfile($startup_pl);
        print $fh $self->startup_pl_code;
        close $fh;
    }

    $self->postamble(IfModule => 'mod_perl.c',
                     "PerlRequire $startup_pl\n");
}

my %sethandler_modperl = (1 => 'perl-script', 2 => 'modperl');

sub set_handler {
    my($self, $module, $args) = @_;
    return if grep { $_ eq 'SetHandler' } @$args;

    push @$args,
      SetHandler =>
        $self->server->version_of(\%sethandler_modperl);
}

sub set_connection_handler {
    my($self, $module, $args) = @_;
    my $port = $self->new_vhost($module);
    my $vars = $self->{vars};
    $self->postamble(Listen => '0.0.0.0:' . $port);
}

my %add_hook_config = (
    Response          => \&set_handler,
    ProcessConnection => \&set_connection_handler,
    PreConnection     => \&set_connection_handler,
);

my %container_config = (
    ProcessConnection => \&vhost_container,
    PreConnection     => \&vhost_container,
);

sub location_container {
    my($self, $module) = @_;
    my $path = Apache::TestRequest::module2path($module);
    Location => "/$path";
}

sub vhost_container {
    my($self, $module) = @_;
    my $port = $self->{vhosts}->{$module}->{port};
    my $namebased = $self->{vhosts}->{$module}->{namebased};

    VirtualHost => ($namebased ? '*' : '_default_') . ":$port";
}

sub new_vhost {
    my($self, $module, $namebased) = @_;
    my($port, $servername, $vhost);

    unless ($namebased and exists $self->{vhosts}->{$module}) {
        $port       = $self->server->select_next_port;
        $vhost      = $self->{vhosts}->{$module} = {};

        $vhost->{port}       = $port;
        $vhost->{namebased}  = $namebased ? 1 : 0;
    }
    else {
        $vhost      = $self->{vhosts}->{$module};
        $port       = $vhost->{port};
        # remember the already configured Listen/NameVirtualHost
        $vhost->{namebased}++;
    }

    $servername = $self->{vars}->{servername};

    $vhost->{servername} = $servername;
    $vhost->{name}       = join ':', $servername, $port;
    $vhost->{hostport}   = $self->hostport($vhost, $module);

    $port;
}

my %outside_container = map { $_, 1 } qw{
Alias AliasMatch AddType
PerlChildInitHandler PerlTransHandler PerlPostReadRequestHandler
PerlSwitches PerlRequire PerlModule
};

my %strip_tags = map { $_ => 1} qw(base noautoconfig);

#test .pm's can have configuration after the __DATA__ token
sub add_module_config {
    my($self, $module, $args) = @_;
    my $fh = Symbol::gensym();
    open($fh, $module) or return;

    while (<$fh>) {
        last if /^(__(DATA|END)__|\#if CONFIG_FOR_HTTPD_TEST)/;
    }