test.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::Test;

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

use Exporter ();
use Config;
use Apache::TestConfig ();

use vars qw(@ISA @EXPORT %EXPORT_TAGS $VERSION %SubTests @SkipReasons);

$VERSION = '1.27';

my @need = qw(need_lwp need_http11 need_cgi need_access need_auth
              need_module need_apache need_min_apache_version
              need_apache_version need_perl need_min_perl_version
              need_min_module_version need_threads need_apache_mpm
              need_php need_php4 need_ssl);

my @have = map { (my $need = $_) =~ s/need/have/; $need } @need;

@ISA = qw(Exporter);
@EXPORT = (qw(ok skip sok plan skip_reason under_construction need),
           @need, @have);

# everything but ok(), skip(), and plan() - Test::More provides these
my @test_more_exports = grep { ! /^(ok|skip|plan)$/ } @EXPORT;

%EXPORT_TAGS = (withtestmore => \@test_more_exports);

%SubTests = ();
@SkipReasons = ();

if (my $subtests = $ENV{HTTPD_TEST_SUBTESTS}) {
    %SubTests = map { $_, 1 } split /\s+/, $subtests;
}

my $Config;
my $real_plan;
my @testmore;

sub import {
    my $class = shift;

    # once Test::More always Test::More until plan() is called
    if (($_[0] and $_[0] =~ m/^-withtestmore/) || @testmore) {
        # special hoops for Test::More support

        $real_plan = eval { 

            require Test::More; 

            no warnings qw(numeric);
            Test::Builder->VERSION('0.18_01');

            # required for Test::More::import() and Apache::Test::plan()
            # if we don't do this, Test::More exports plan() anyway
            # and we get collisions.  go figure.
            @testmore = (import => [qw(!plan)]);

            Test::More->import(@testmore);

            \&Test::More::plan;
        } or die "-withtestmore error: $@";

        # clean up arguments to export_to_level
        shift;
        @EXPORT = (@test_more_exports, @Test::More::EXPORT);
    }
    else {
        # the default - Test.pm support

        require Test;
        Test->import(qw(ok skip));
        @testmore = ();               # reset, just in case.
        $real_plan = \&Test::plan;
    }

    $class->export_to_level(1, undef, @_ ? @_ : @EXPORT);
}

sub config {
    $Config ||= Apache::TestConfig->thaw->httpd_config;
}

my $Basic_config;

# config bits which doesn't require httpd to be found
sub basic_config {
    $Basic_config ||= Apache::TestConfig->thaw();
}

sub vars {
    @_ ? @{ config()->{vars} }{ @_ } : config()->{vars};
}

sub sok (&;$) {
    my $sub = shift;
    my $nok = shift || 1; #allow sok to have 'ok' within

    if (%SubTests and not $SubTests{ $Test::ntest }) {
        for my $n (1..$nok) {
            skip("skipping this subtest", 0);
        }
        return;
    }

    my($package, $filename, $line) = caller;

    # trick ok() into reporting the caller filename/line when a
    # sub-test fails in sok()
    return eval <<EOE;
#line $line $filename
    ok(\$sub->());
EOE
}

#so Perl's Test.pm can be run inside mod_perl
sub test_pm_refresh {
    if (@testmore) {
        my $builder = Test::Builder->new;

        $builder->reset;

        $builder->output(\*STDOUT);
        $builder->todo_output(\*STDOUT);

        # this is STDOUT because Test::More seems to put 
        # most of the stuff we want on STDERR, so it ends
        # up in the error_log instead of where the user can
        # see it.   consider leaving it alone based on
        # later user reports.
        $builder->failure_output(\*STDOUT);
    }
    else {
        $Test::TESTOUT = \*STDOUT;
        $Test::planned = 0;
        $Test::ntest = 1;
        %Test::todo = ();
    }
}

sub init_test_pm {
    my $r = shift;

    # needed to load Apache2::RequestRec::TIEHANDLE
    eval {require Apache2::RequestIO};
    if (defined &Apache2::RequestRec::TIEHANDLE) {
        untie *STDOUT;
        tie *STDOUT, $r;
        require Apache2::RequestRec; # $r->pool
        require APR::Pool;
        $r->pool->cleanup_register(sub { untie *STDOUT });
    }
    else {
        $r->send_http_header; #1.xx
    }

    $r->content_type('text/plain');
}

sub need_http11 {
    require Apache::TestRequest;
    if (Apache::TestRequest::install_http11()) {
        return 1;
    }
    else {
        push @SkipReasons,
           "LWP version 5.60+ required for HTTP/1.1 support";
        return 0;
    }
}

sub need_ssl {
    my $vars = vars();
    need_module([$vars->{ssl_module_name}, 'Net::SSL']);
}

sub need_lwp {
    require Apache::TestRequest;
    if (Apache::TestRequest::has_lwp()) {
        return 1;
    }
    else {
        push @SkipReasons, "libwww-perl is not installed";
        return 0;
    }
}

sub plan {
    init_test_pm(shift) if ref $_[0];
    test_pm_refresh();

    # extending Test::plan's functionality, by using the optional
    # single value in @_ coming after a ballanced %hash which
    # Test::plan expects
    if (@_ % 2) {
        my $condition = pop @_;
        my $ref = ref $condition;
        my $meets_condition = 0;
        if ($ref) {
            if ($ref eq 'CODE') {
                #plan tests $n, \&has_lwp
                $meets_condition = $condition->();
            }
            elsif ($ref eq 'ARRAY') {
                #plan tests $n, [qw(php4 rewrite)];
                $meets_condition = need_module($condition);
            }
            else {
                die "don't know how to handle a condition of type $ref";
            }
        }
        else {
            # we have the verdict already: true/false
            $meets_condition = $condition ? 1 : 0;
        }

        # trying to emulate a dual variable (ala errno)
        unless ($meets_condition) {
            my $reason = join ', ',
              @SkipReasons ? @SkipReasons : "no reason given";
            print "1..0 # skipped: $reason\n";
            @SkipReasons = (); # reset
            exit; #XXX: Apache->exit
        }
    }
    @SkipReasons = (); # reset

    $real_plan->(@_, @testmore);

    # add to Test.pm verbose output
    print "# Using Apache/Test.pm version $VERSION\n";
}

sub need {
    my $need_all = 1;
    for my $cond (@_) {
        if (ref $cond eq 'HASH') {
            while (my($reason, $value) = each %$cond) {
                $value = $value->() if ref $value eq 'CODE';
                next if $value;
                push @SkipReasons, $reason;
                $need_all = 0;
            }
        }
        elsif ($cond =~ /^(0|1)$/) {
            $need_all = 0 if $cond == 0;
        }
        else {
            $need_all = 0 unless need_module($cond);
        }
    }
    return $need_all;

}

sub need_module {
    my $cfg = config();

    my @modules = grep defined $_,
        ref($_[0]) eq 'ARRAY' ? @{ $_[0] } : @_;

    my @reasons = ();
    for (@modules) {
        if (/^[a-z0-9_.]+$/) {
            my $mod = $_;
            $mod .= '.c' unless $mod =~ /\.c$/;
            next if $cfg->{modules}->{$mod};
            $mod = 'mod_' . $mod unless $mod =~ /^mod_/;
            next if $cfg->{modules}->{$mod};
            if (exists $cfg->{cmodules_disabled}->{$mod}) {
                push @reasons, $cfg->{cmodules_disabled}->{$mod};
                next;
            }
        }
        die "bogus module name $_" unless /^[\w:.]+$/;

        # if the module was explicitly passed with a .c extension,
        # do not try to eval it as a Perl module
        my $not_found = 1;
        unless (/\.c$/) {
            eval "require $_";
            $not_found = 0 unless $@;
            #print $@ if $@;
        }
        push @reasons, "cannot find module '$_'" if $not_found;

    }
    if (@reasons) {
        push @SkipReasons, @reasons;
        return 0;
    }
    else {
        return 1;
    }
}

sub need_min_perl_version {
    my $version = shift;

    return 1 if $] >= $version;

    push @SkipReasons, "perl >= $version is required";
    return 0;
}

# currently supports only perl modules
sub need_min_module_version {
    my($module, $version) = @_;

    # need_module requires the perl module
    return 0 unless need_module($module);

    # support dev versions like 0.18_01
    return 1
        if eval { no warnings qw(numeric); $module->VERSION($version) };

    push @SkipReasons, "$module version $version or higher is required";
    return 0;
}

sub need_cgi {
    need_module('cgi') || need_module('cgid');
}

sub need_php {
    need_module('php4') || need_module('php5') || need_module('sapi_apache2.c');
}

sub need_php4 {
    need_module('php4') || need_module('sapi_apache2.c');
}

sub need_access {
    need_module('access') || need_module('authz_host');
}

sub need_auth {
    need_module('auth') || need_module('auth_basic');
}

sub need_apache {
    my $version = shift;
    my $cfg = Apache::Test::config();
    my $rev = $cfg->{server}->{rev};

    if ($rev == $version) {
        return 1;
    }
    else {
        push @SkipReasons,
          "apache version $version required, this is version $rev";
        return 0;
    }
}

sub need_min_apache_version {
    my $wanted = shift;
    my $cfg = Apache::Test::config();
    (my $current) = $cfg->{server}->{version} =~ m:^Apache/(\d\.\d+\.\d+):;

    if (normalize_vstring($current) < normalize_vstring($wanted)) {
        push @SkipReasons,
          "apache version $wanted or higher is required," .
          " this is version $current";
        return 0;
    }
    else {
        return 1;
    }
}

sub need_apache_version {
    my $wanted = shift;
    my $cfg = Apache::Test::config();
    (my $current) = $cfg->{server}->{version} =~ m:^Apache/(\d\.\d+\.\d+):;

    if (normalize_vstring($current) != normalize_vstring($wanted)) {
        push @SkipReasons,
          "apache version $wanted or higher is required," .
          " this is version $current";
        return 0;
    }
    else {
        return 1;
    }
}

sub need_apache_mpm {
    my $wanted = shift;
    my $cfg = Apache::Test::config();
    my $current = $cfg->{server}->{mpm};

    if ($current ne $wanted) {
        push @SkipReasons,
          "apache $wanted mpm is required," .
          " this is the $current mpm";
        return 0;
    }
    else {
        return 1;
    }
}

sub config_enabled {
    my $key = shift;
    defined $Config{$key} and $Config{$key} eq 'define';
}

sub need_perl_iolayers {
    if (my $ext = $Config{extensions}) {
        #XXX: better test?  might need to test patchlevel
        #if support depends bugs fixed in bleedperl
        return $ext =~ m:PerlIO/scalar:;
    }
    0;
}

sub need_perl {
    my $thing = shift;
    #XXX: $thing could be a version
    my $config;

    my $have = \&{"need_perl_$thing"};
    if (defined &$have) {
        return 1 if $have->();
    }
    else {
        for my $key ($thing, "use$thing") {
            if (exists $Config{$key}) {
                $config = $key;
                return 1 if config_enabled($key);
            }
        }
    }

    push @SkipReasons, $config ?
      "Perl was not built with $config enabled" :
        "$thing is not available with this version of Perl";

    return 0;
}

sub need_threads {
    my $status = 1;

    # check APR support
    my $build_config = Apache::TestConfig->modperl_build_config;

    if ($build_config) {
        my $apr_config = $build_config->get_apr_config();
        unless ($apr_config->{HAS_THREADS}) {
            $status = 0;
            push @SkipReasons, "Apache/APR was built without threads support";
        }
    }

    # check Perl's useithreads
    my $key = 'useithreads';
    unless (exists $Config{$key} and config_enabled($key)) {
        $status = 0;
        push @SkipReasons, "Perl was not built with 'ithreads' enabled";
    }

    return $status;
}

sub under_construction {
    push @SkipReasons, "This test is under construction";
    return 0;
}

sub skip_reason {
    my $reason = shift || 'no reason specified';
    push @SkipReasons, $reason;
    return 0;
}

# normalize Apache-style version strings (2.0.48, 0.9.4)
# for easy numeric comparison.  note that 2.1 and 2.1.0
# are considered equivalent.
sub normalize_vstring {

    my @digits = shift =~ m/(\d+)\.?(\d*)\.?(\d*)/;

    return join '', map { sprintf("%03d", $_ || 0) } @digits;
}

# have_ functions are the same as need_ but they don't populate
# @SkipReasons
for my $func (@have) {
    no strict 'refs';