testrun.pm

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

    my $self = shift;
    if ($? && !$self->user_error &&
        $self->{opts}->{bugreport} && $self->can('bug_report')) {
        $self->bug_report;
    }
}

#throw away cached config and start fresh
sub refresh {
    my $self = shift;
    $self->opt_clean(1);
    $self->{conf_opts}->{save} = delete $self->{conf_opts}->{thaw} || 1;
    $self->{test_config} = $self->new_test_config()->httpd_config;
    $self->{test_config}->{server}->{run} = $self;
    $self->{server} = $self->{test_config}->server;
}

sub configure_opts {
    my $self = shift;
    my $save = shift;
    my $refreshed = 0;

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

    $test_config->{vars}->{scheme} =
      $opts->{ssl} ? 'https' :
        $self->{conf_opts}->{scheme} || 'http';

    if ($opts->{http11}) {
        $ENV{APACHE_TEST_HTTP11} = 1;
    }

    # unless we are already reconfiguring, check for .conf.in files changes
    if (!$$save &&
        (my @reasons =
         $self->{test_config}->need_reconfiguration($self->{conf_opts}))) {
        warning "forcing re-configuration:";
        warning "\t- $_." for @reasons;
        unless ($refreshed) {
            $self->refresh;
            $refreshed = 1;
            $test_config = $self->{test_config};
        }
    }

    # unless we are already reconfiguring, check for -proxy
    if (!$$save && exists $opts->{proxy}) {
        my $max = $test_config->{vars}->{maxclients};
        $opts->{proxy} ||= 'on';

        #if config is cached and MaxClients == 1, must reconfigure
        if (!$$save and $opts->{proxy} eq 'on' and $max == 1) {
            $$save = 1;
            warning "server is reconfigured for proxy";
            unless ($refreshed) {
                $self->refresh;
                $refreshed = 1;
                $test_config = $self->{test_config};
            }
        }

        $test_config->{vars}->{proxy} = $opts->{proxy};
    }
    else {
        $test_config->{vars}->{proxy} = 'off';
    }

    return unless $$save;

    my $preamble  = sub { shift->preamble($opts->{preamble}) };
    my $postamble = sub { shift->postamble($opts->{postamble}) };

    $test_config->preamble_register($preamble);
    $test_config->postamble_register($postamble);
}

sub pre_configure { }

sub configure {
    my $self = shift;

    if ($self->{opts}->{'no-httpd'}) {
        warning "skipping httpd configuration";
        return;
    }

    # create the conf dir as early as possible
    $self->{test_config}->prepare_t_conf();

    my $save = \$self->{conf_opts}->{save};
    $self->configure_opts($save);

    my $config = $self->{test_config};
    unless ($$save) {
        my $addr = \$config->{vars}->{remote_addr};
        my $remote_addr = $config->our_remote_addr;
        unless ($$addr eq $remote_addr) {
            warning "local ip address has changed, updating config cache";
            $$addr = $remote_addr;
        }
        #update minor changes to cached config
        #without complete regeneration
        #for example this allows switching between
        #'t/TEST' and 't/TEST -ssl'
        $config->sync_vars(qw(scheme proxy remote_addr));
        return;
    }

    my $test_config = $self->{test_config};
    $test_config->sslca_generate;
    $test_config->generate_ssl_conf if $self->{opts}->{ssl};
    $test_config->cmodules_configure;
    $test_config->generate_httpd_conf;
    $test_config->save;

    # custom config save if
    # 1) requested to save
    # 2) no saved config yet
    if ($self->{opts}->{save} or
        !Apache::TestConfig::custom_config_exists()) {
        $test_config->custom_config_save($self->{conf_opts});
    }
}

sub try_exit_opts {
    my $self = shift;
    my @opts = @_;

    for (@opts) {
        next unless exists $self->{opts}->{$_};
        my $method = "opt_$_";
        my $rc = $self->$method();
        exit_perl $rc if $rc;
    }

    if ($self->{opts}->{'stop-httpd'}) {
        my $ok = 1;
        if ($self->{server}->ping) {
            $ok = $self->{server}->stop;
            $ok = $ok < 0 ? 0 : 1; # adjust to 0/1 logic
        }
        else {
            warning "server $self->{server}->{name} is not running";
            # cleanup a stale httpd.pid file if found
            my $t_logs  = $self->{test_config}->{vars}->{t_logs};
            my $pid_file = catfile $t_logs, "httpd.pid";
            unlink $pid_file if -e $pid_file;
        }
        exit_perl $ok;
    }
}

sub start {
    my $self = shift;

    my $opts = $self->{opts};
    my $server = $self->{server};

    #if t/TEST -d is running make sure we don't try to stop/start the server
    my $file = $server->debugger_file;
    if (-e $file and $opts->{'start-httpd'}) {
        if ($server->ping) {
            warning "server is running under the debugger, " .
                "defaulting to -run";
            $opts->{'start-httpd'} = $opts->{'stop-httpd'} = 0;
        }
        else {
            warning "removing stale debugger note: $file";
            unlink $file;
        }
    }

    $self->adjust_t_perms();

    if ($opts->{'start-httpd'}) {
        exit_perl 0 unless $server->start;
    }
    elsif ($opts->{'run-tests'}) {
        my $is_up = $server->ping
            || (exists $self->{opts}->{ping}
                && $self->{opts}->{ping}  eq 'block'
                && $server->wait_till_is_up(STARTUP_TIMEOUT));
        unless ($is_up) {
            error "server is not ready yet, try again.";
            exit_perl 0;
        }
    }
}

sub run_tests {
    my $self = shift;

    my $test_opts = {
        verbose => $self->{opts}->{verbose},
        tests   => $self->{tests},
        times   => $self->{opts}->{times},
        order   => $self->{opts}->{order},
        subtests => $self->{subtests} || [],
    };

    if (grep { exists $self->{opts}->{$_} } @request_opts) {
        run_request($self->{test_config}, $self->{opts});
    }
    else {
        Apache::TestHarness->run($test_opts)
            if $self->{opts}->{'run-tests'};
    }
}

sub stop {
    my $self = shift;

    $self->restore_t_perms;

    return $self->{server}->stop if $self->{opts}->{'stop-httpd'};
}

sub new_test_config {
    my $self = shift;

    Apache::TestConfig->new($self->{conf_opts});
}

sub set_ulimit_via_sh {
    return if Apache::TestConfig::WINFU;
    return if $ENV{APACHE_TEST_ULIMIT_SET};

    # only root can allow unlimited core dumps on Solaris (8 && 9?)
    if (Apache::TestConfig::SOLARIS) {
        my $user = getpwuid($>) || '';
        if ($user ne 'root') {
            warning "Skipping 'set unlimited ulimit for coredumps', " .
                "since we are running as a non-root user on Solaris";
            return;
        }
    }

    my $binsh = '/bin/sh';
    return unless -e $binsh;
    $ENV{APACHE_TEST_ULIMIT_SET} = 1;

    my $sh = Symbol::gensym();
    open $sh, "echo ulimit -a | $binsh|" or die;
    local $_;
    while (<$sh>) {
        if (/^core.*unlimited$/) {
            #already set to unlimited
            $ENV{APACHE_TEST_ULIMIT_SET} = 1;
            return;
        }
    }
    close $sh;

    $orig_command = "ulimit -c unlimited; $orig_command";
    warning "setting ulimit to allow core files\n$orig_command";
    # use 'or die' to avoid warnings due to possible overrides of die
    exec $orig_command or die "exec $orig_command has failed";
}

sub set_ulimit {
    my $self = shift;
    #return if $self->set_ulimit_via_bsd_resource;
    eval { $self->set_ulimit_via_sh };
}

sub set_env {
    #export some environment variables for t/modules/env.t
    #(the values are unimportant)
    $ENV{APACHE_TEST_HOSTNAME} = 'test.host.name';
    $ENV{APACHE_TEST_HOSTTYPE} = 'z80';
}

sub run {
    my $self = shift;

    # assuming that test files are always in the same directory as the
    # driving script, make it possible to run the test suite from any place
    # use a full path, which will work after chdir (e.g. ./TEST)
    $0 = File::Spec->rel2abs($0);
    if (-e $0) {
        my $top = dirname dirname $0;
        chdir $top if $top and -d $top;
    }

    # reconstruct argv, preserve multiwords args, eg 'PerlTrace all'
    my $argv = join " ", map { /^-/ ? $_ : qq['$_'] } @ARGV;
    $orig_command = "$^X $0 $argv";
    $orig_cwd = Cwd::cwd();
    $self->set_ulimit;
    $self->set_env; #make sure these are always set

    $self->detect_relocation($orig_cwd);

    my(@argv) = @_;

    $self->getopts(\@argv);

    # must be called after getopts so the tracing will be set right
    Apache::TestConfig::custom_config_load();

    $self->pre_configure();

    # can't setup the httpd-specific parts of the config object yet
    $self->{test_config} = $self->new_test_config();

    $self->warn_core();

    # give TestServer access to our runtime configuration directives
    # so we can tell the server stuff if we need to
    $self->{test_config}->{server}->{run} = $self;

    $self->{server} = $self->{test_config}->server;

    local($SIG{__DIE__}, $SIG{INT});
    $self->install_sighandlers;

    $self->try_exit_opts(@exit_opts_no_need_httpd);

    # httpd is found here (unless it was already configured before)
    $self->{test_config}->httpd_config();

    $self->try_exit_opts(@exit_opts_need_httpd);

    if ($self->{opts}->{configure}) {
        warning "cleaning out current configuration";
        $self->opt_clean(1);
    }

    # if configure() fails for some reason before it has flushed the
    # config to a file, save it so -clean will be able to clean
    unless ($self->{opts}->{clean}) {
        eval { $self->configure };
        if ($@) {
            error "configure() has failed:\n$@";
            warning "forcing Apache::TestConfig object save";
            $self->{test_config}->save;
            warning "run 't/TEST -clean' to clean up before continuing";
            exit_perl 0;
        }
    }

    if ($self->{opts}->{configure}) {
        warning "reconfiguration done";
        exit_perl 1;
    }

    $self->default_run_opts;

    $self->split_test_args;

    $self->die_on_invalid_args;

    $self->start unless $self->{opts}->{'no-httpd'};

    $self->run_tests;

    $self->stop unless $self->{opts}->{'no-httpd'};
}

sub rerun {
    my $vars = shift;

    # in %$vars
    # - httpd will be always set
    # - apxs is optional

    $orig_cwd ||= Cwd::cwd();
    chdir $orig_cwd;
    my $new_opts = " -httpd $vars->{httpd}";
    $new_opts .= " -apxs $vars->{apxs}" if $vars->{apxs};

    my $new_command = $orig_command;

    # strip any old bogus -httpd/-apxs
    $new_command =~ s/--?httpd\s+$orig_conf_opts->{httpd}//
        if $orig_conf_opts->{httpd};
    $new_command =~ s/--?httpd\s+$orig_conf_opts->{httpd}//
        if $orig_conf_opts->{httpd} and $vars->{apxs};

    # add new opts
    $new_command .= $new_opts;

    warning "running with new config opts: $new_command";

    # use 'or die' to avoid warnings due to possible overrides of die
    exec $new_command or die "exec $new_command has failed";
}


# make it easy to move the whole distro w/o running
# 't/TEST -clean' before moving. when moving the whole package,
# the old cached config will stay, so we want to nuke it only if
# we realize that it's no longer valid. we can't just check the
# existance of the saved top_dir value, since the project may have