testrun.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::TestRun;

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

use Apache::Test ();
use Apache::TestMM ();
use Apache::TestConfig ();
use Apache::TestConfigC ();
use Apache::TestRequest ();
use Apache::TestHarness ();
use Apache::TestTrace;

use Cwd;
use ExtUtils::MakeMaker;
use File::Find qw(finddepth);
use File::Path;
use File::Spec::Functions qw(catfile catdir canonpath);
use File::Basename qw(basename dirname);
use Getopt::Long qw(GetOptions);
use Config;

use constant IS_APACHE_TEST_BUILD => Apache::TestConfig::IS_APACHE_TEST_BUILD;

use constant STARTUP_TIMEOUT => 300; # secs (good for extreme debug cases)

use subs qw(exit_shell exit_perl);

my $orig_command;
my $orig_cwd;
my $orig_conf_opts;

my %core_files  = ();
my %original_t_perms = ();

my @std_run      = qw(start-httpd run-tests stop-httpd);
my @others       = qw(verbose configure clean help ssl http11 bugreport 
                      save no-httpd one-process);
my @flag_opts    = (@std_run, @others);
my @string_opts  = qw(order trace);
my @ostring_opts = qw(proxy ping);
my @debug_opts   = qw(debug);
my @num_opts     = qw(times);
my @list_opts    = qw(preamble postamble breakpoint);
my @hash_opts    = qw(header);
my @help_opts    = qw(clean help);
my @request_opts = qw(get post head);

my @exit_opts_no_need_httpd = (@help_opts);
my @exit_opts_need_httpd    = (@debug_opts, qw(ping));

my %usage = (
   'start-httpd'     => 'start the test server',
   'run-tests'       => 'run the tests',
   'times=N'         => 'repeat the tests N times',
   'order=mode'      => 'run the tests in one of the modes: ' .
                        '(repeat|rotate|random|SEED)',
   'stop-httpd'      => 'stop the test server',
   'no-httpd'        => 'run the tests without configuring or starting httpd',
   'verbose[=1]'     => 'verbose output',
   'configure'       => 'force regeneration of httpd.conf ' .
                        ' (tests will not be run)',
   'clean'           => 'remove all generated test files',
   'help'            => 'display this message',
   'bugreport'       => 'print the hint how to report problems',
   'preamble'        => 'config to add at the beginning of httpd.conf',
   'postamble'       => 'config to add at the end of httpd.conf',
   'ping[=block]'    => 'test if server is running or port in use',
   'debug[=name]'    => 'start server under debugger name (gdb, ddd, etc.)',
   'breakpoint=bp'   => 'set breakpoints (multiply bp can be set)',
   'header'          => "add headers to (" .
                         join('|', @request_opts) . ") request",
   'http11'          => 'run all tests with HTTP/1.1 (keep alive) requests',
   'ssl'             => 'run tests through ssl',
   'proxy'           => 'proxy requests (default proxy is localhost)',
   'trace=T'         => 'change tracing default to: warning, notice, ' .
                        'info, debug, ...',
   'save'            => 'save test paramaters into Apache::TestConfigData',
   'one-process'     => 'run the server in single process mode',
   (map { $_, "\U$_\E url" } @request_opts),
);

sub fixup {
    #make sure we use an absolute path to perl
    #else Test::Harness uses the perl in our PATH
    #which might not be the one we want
    $^X = $Config{perlpath} unless -e $^X;
}

# if the test suite was aborted because of a user-error we don't want
# to call the bugreport and invite users to submit a bug report -
# after all it's a user error. but we still want the program to fail,
# so raise this flag in such a case.
my $user_error = 0;
sub user_error {
    my $self = shift;
    $user_error = shift if @_;
    $user_error;
}

sub new {
    my $class = shift;

    my $self = bless {
        tests => [],
        @_,
    }, $class;

    $self->fixup;

    $self;
}

#split arguments into test files/dirs and options
#take extra care if -e, the file matches /\.t$/
#                if -d, the dir contains .t files
#so we dont slurp arguments that are not tests, example:
# httpd $HOME/apache-2.0/bin/httpd

sub split_test_args {
    my($self) = @_;

    my(@tests);
    my $top_dir = $self->{test_config}->{vars}->{top_dir};
    my $t_dir = $self->{test_config}->{vars}->{t_dir};

    my $argv = $self->{argv};
    my @leftovers = ();
    for (@$argv) {
        my $arg = $_;
        # need the t/ (or t\) for stat-ing, but don't want to include
        # it in test output
        $arg =~ s@^(?:\.[\\/])?t[\\/]@@;
        my $file = catfile $t_dir, $arg;
        if (-d $file and $_ ne '/') {
            my @files = <$file/*.t>;
            my $remove = catfile $top_dir, "";
            if (@files) {
                push @tests, map { s,^\Q$remove,,; $_ } @files;
                next;
            }
        }
        else {
            if ($file =~ /\.t$/ and -e $file) {
                push @tests, "t/$arg";
                next;
            }
            elsif (-e "$file.t") {
                push @tests, "t/$arg.t";
                next;
            }
            elsif (/^[\d.]+$/) {
                my @t = $_;
                #support range of subtests: t/TEST t/foo/bar 60..65
                if (/^(\d+)\.\.(\d+)$/) {
                    @t =  $1..$2;
                }

                push @{ $self->{subtests} }, @t;
                next;
            }
        }
        push @leftovers, $_;
    }

    $self->{tests} = [ map { canonpath($_) } @tests ];
    $self->{argv}  = \@leftovers;
}

sub die_on_invalid_args {
    my($self) = @_;

    # at this stage $self->{argv} should be empty
    my @invalid_argv = @{ $self->{argv} };
    if (@invalid_argv) {
        error "unknown opts or test names: @invalid_argv\n" .
            "-help will list options\n";
        exit_perl 0;
    }

}

sub passenv {
    my $passenv = Apache::TestConfig->passenv;
    for (keys %$passenv) {
        return 1 if $ENV{$_};
    }
    0;
}

sub getopts {
    my($self, $argv) = @_;

    local *ARGV = $argv;
    my(%opts, %vopts, %conf_opts);

    # a workaround to support -verbose and -verbose=0|1
    # $Getopt::Long::VERSION > 2.26 can use the "verbose:1" rule
    # but we have to support older versions as well
    @ARGV = grep defined, 
        map {/-verbose=(\d)/ ? ($1 ? '-verbose' : undef) : $_ } @ARGV;

    # permute      : optional values can come before the options
    # pass_through : all unknown things are to be left in @ARGV
    Getopt::Long::Configure(qw(pass_through permute));

    # grab from @ARGV only the options that we expect
    GetOptions(\%opts, @flag_opts, @help_opts,
               (map "$_:s", @debug_opts, @request_opts, @ostring_opts),
               (map "$_=s", @string_opts),
               (map "$_=i", @num_opts),
               (map { ("$_=s", $vopts{$_} ||= []) } @list_opts),
               (map { ("$_=s", $vopts{$_} ||= {}) } @hash_opts));

    $opts{$_} = $vopts{$_} for keys %vopts;

    # separate configuration options and test files/dirs
    my $req_wanted_args = Apache::TestRequest::wanted_args();
    my @argv = ();
    my %req_args = ();

    while (@ARGV) {
        my $val = shift @ARGV;
        if ($val =~ /^--?(.+)/) { # must have a leading - or --
            my $key = lc $1;
            # a known config option?
            if (exists $Apache::TestConfig::Usage{$key}) {
                $conf_opts{$key} = shift @ARGV;
                next;
            } # a TestRequest config option?
            elsif (exists $req_wanted_args->{$key}) {
                $req_args{$key} = shift @ARGV;
                next;
            }
        }
        # to be processed later
        push @argv, $val;
    }

    # save the orig args (make a deep copy)
    $orig_conf_opts = { %conf_opts };

    # fixup the filepath options on win32 (spaces, short names, etc.)
    if (Apache::TestConfig::WIN32) {
        for my $key (keys %conf_opts) {
            next unless Apache::TestConfig::conf_opt_is_a_filepath($key);
            next unless -e $conf_opts{$key};
            $conf_opts{$key} = Win32::GetShortPathName($conf_opts{$key});
        }
    }

    $opts{req_args} = \%req_args;

    # only test files/dirs if any at all are left in argv
    $self->{argv} = \@argv;

    # force regeneration of httpd.conf if commandline args want to
    # modify it. configure_opts() has more checks to decide whether to
    # reconfigure or not.
    # XXX: $self->passenv() is already tested in need_reconfiguration()
    $self->{reconfigure} = $opts{configure} ||
      (grep { $opts{$_}->[0] } qw(preamble postamble)) ||
        (grep { $Apache::TestConfig::Usage{$_} } keys %conf_opts ) ||
          $self->passenv() || (! -e 't/conf/httpd.conf');

    if (exists $opts{debug}) {
        $opts{debugger} = $opts{debug};
        $opts{debug} = 1;
    }

    if ($opts{trace}) {
        my %levels = map {$_ => 1} @Apache::TestTrace::Levels;
        if (exists $levels{ $opts{trace} }) {
            $Apache::TestTrace::Level = $opts{trace};
            # propogate the override for the server-side.
            # -trace overrides any previous APACHE_TEST_TRACE_LEVEL settings
            $ENV{APACHE_TEST_TRACE_LEVEL} = $opts{trace};
        }
        else {
            error "unknown trace level: $opts{trace}",
                "valid levels are: @Apache::TestTrace::Levels";
            exit_perl 0;
        }
    }

    # breakpoint automatically turns the debug mode on
    if (@{ $opts{breakpoint} }) {
        $opts{debug} ||= 1;
    }

    if ($self->{reconfigure}) {
        $conf_opts{save} = 1;
        delete $self->{reconfigure};
    }
    else {
        $conf_opts{thaw} = 1;
    }

    #propagate some values
    for (qw(verbose)) {
        $conf_opts{$_} = $opts{$_};
    }

    $self->{opts} = \%opts;
    $self->{conf_opts} = \%conf_opts;
}

sub default_run_opts {
    my $self = shift;
    my($opts, $tests) = ($self->{opts}, $self->{tests});

    unless (grep { exists $opts->{$_} } @std_run, @request_opts) {
        if (@$tests && $self->{server}->ping) {
            # if certain tests are specified and server is running,
            # dont restart
            $opts->{'run-tests'} = 1;
        }
        else {
            #default is server-server run-tests stop-server
            $opts->{$_} = 1 for @std_run;
        }
    }

    $opts->{'run-tests'} ||= @$tests;
}

my $parent_pid = $$;
sub is_parent { $$ == $parent_pid }

my $caught_sig_int = 0;

sub install_sighandlers {
    my $self = shift;

    my($server, $opts) = ($self->{server}, $self->{opts});

    $SIG{__DIE__} = sub {
        return unless $_[0] =~ /^Failed/i; #dont catch Test::ok failures

        # _show_results() calls die() under a few conditions, such as
        # when no tests are run or when tests fail.  make sure the message
        # is propagated back to the user.
        print $_[0] if (caller(1))[3]||'' eq 'Test::Harness::_show_results';

        $server->stop(1) if $opts->{'start-httpd'};
        $server->failed_msg("error running tests");
        exit_perl 0;
    };

    $SIG{INT} = sub {
        if ($caught_sig_int++) {
            warning "\ncaught SIGINT";
            exit_perl 0;
        }
        warning "\nhalting tests";
        $server->stop if $opts->{'start-httpd'};
        exit_perl 0;
    };

    #try to make sure we scan for core no matter what happens
    #must eval "" to "install" this END block, otherwise it will
    #always run, a subclass might not want that
    eval 'END {
        return unless is_parent(); # because of fork
        $self ||=
            Apache::TestRun->new(test_config => Apache::TestConfig->thaw);
        {
            local $?; # preserve the exit status
            eval {
               $self->scan_core;
            };
        }
        $self->try_bug_report();
    }';
    die "failed: $@" if $@;

}

sub try_bug_report {