| # Licensed to the Apache Software Foundation (ASF) under one or more |
| # contributor license agreements. See the NOTICE file distributed with |
| # this work for additional information regarding copyright ownership. |
| # The ASF licenses this file to You 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 @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 @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', |
| 'order=mode' => 'run the tests in one of the modes: ' . |
| '(repeat|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, ...', |
| '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 { ("$_=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 start-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 { |
| 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; |
| |
| } |
| |
| 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 pid file if found |
| my $pid_file = $self->{test_config}->{vars}->{t_pid_file}; |
| 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->check_runtime_user(); |
| |
| 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}, |
| 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; |
| |
| 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); |
| |
| $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); |
| } |
| |
| $self->split_test_args; |
| |
| $self->die_on_invalid_args; |
| |
| $self->default_run_opts; |
| |
| # if configure() fails for some reason before it has flushed the |
| # config to a file, save it so -clean will be able to clean |
| if ($self->{opts}->{'start-httpd'} || $self->{opts}->{'configure'}) { |
| 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->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 |
| # been copied and the old dir could be still there, but that's not |
| # the one that we work in |
| sub detect_relocation { |
| my($self, $cur_top_dir) = @_; |
| |
| my $config_file = catfile qw(t conf apache_test_config.pm); |
| return unless -e $config_file; |
| |
| my %inc = %INC; |
| eval { require "./$config_file" }; |
| %INC = %inc; # be stealth |
| warn($@), return if $@; |
| |
| my $cfg = 'apache_test_config'->new; |
| |
| # if the top_dir from saved config doesn't match the current |
| # top_dir, that means that the whole project was relocated to a |
| # different directory, w/o running t/TEST -clean first (in each |
| # directory with a test suite) |
| my $cfg_top_dir = $cfg->{vars}->{top_dir}; |
| return unless $cfg_top_dir; |
| return if $cfg_top_dir eq $cur_top_dir; |
| |
| # if that's the case silently fixup the saved config to use the |
| # new paths, and force a complete cleanup. if we don't fixup the |
| # config files, the cleanup process won't be able to locate files |
| # to delete and re-configuration will fail |
| { |
| # in place editing |
| local @ARGV = $config_file; |
| local $^I = ".bak"; # Win32 needs a backup |
| while (<>) { |
| s{$cfg_top_dir}{$cur_top_dir}g; |
| print; |
| } |
| unlink $config_file . $^I; |
| } |
| |
| my $cleanup_cmd = "$^X $0 -clean"; |
| warning "cleaning up the old config"; |
| # XXX: do we care to check success? |
| system $cleanup_cmd; |
| |
| # XXX: I tried hard to accomplish that w/o starting a new process, |
| # but too many things get on the way, so for now just keep it as an |
| # external process, as it's absolutely transparent to the normal |
| # app-run |
| } |
| |
| my @oh = qw(jeez golly gosh darn shucks dangit rats nuts dangnabit crap); |
| sub oh { |
| $oh[ rand scalar @oh ]; |
| } |
| |
| #e.g. t/core or t/core.12499 |
| my $core_pat = '^core(\.\d+)?' . "\$"; |
| |
| # $self->scan_core_incremental([$only_top_dir]) |
| # normally would be called after each test |
| # and since it updates the list of seen core files |
| # scan_core() won't report these again |
| # currently used in Apache::TestSmoke |
| # |
| # if $only_t_dir arg is true only the t_dir dir (t/) will be scanned |
| sub scan_core_incremental { |
| my($self, $only_t_dir) = @_; |
| my $vars = $self->{test_config}->{vars}; |
| |
| # no core files dropped on win32 |
| return () if Apache::TestConfig::WIN32; |
| |
| if ($only_t_dir) { |
| require IO::Dir; |
| my @cores = (); |
| for (IO::Dir->new($vars->{t_dir})->read) { |
| my $file = catfile $vars->{t_dir}, $_; |
| next unless -f $file; |
| next unless /$core_pat/o; |
| next if exists $core_files{$file} && |
| $core_files{$file} == -M $file; |
| $core_files{$file} = -M $file; |
| push @cores, $file; |
| } |
| return @cores |
| ? join "\n", "server dumped core, for stacktrace, run:", |
| map { "gdb $vars->{httpd} -core $_" } @cores |
| : (); |
| } |
| |
| my @msg = (); |
| finddepth({ no_chdir => 1, |
| wanted => sub { |
| return unless -f $_; |
| my $file = basename $File::Find::name; |
| return unless $file =~ /$core_pat/o; |
| my $core = $File::Find::name; |
| unless (exists $core_files{$core} && $core_files{$core} == -M $core) { |
| # new core file! |
| |
| # XXX: could rename the file if it doesn't include the pid |
| # in its name (i.e., just called 'core', instead of 'core.365') |
| |
| # XXX: could pass the test name and rename the core file |
| # to use that name as a suffix, plus pid, time or some |
| # other unique identifier, in case the same test is run |
| # more than once and each time it caused a segfault |
| $core_files{$core} = -M $core; |
| push @msg, "server dumped core, for stacktrace, run:\n" . |
| "gdb $vars->{httpd} -core $core"; |
| } |
| }}, $vars->{top_dir}); |
| |
| return @msg; |
| |
| } |
| |
| sub scan_core { |
| my $self = shift; |
| my $vars = $self->{test_config}->{vars}; |
| my $times = 0; |
| |
| # no core files dropped on win32 |
| return if Apache::TestConfig::WIN32; |
| |
| finddepth({ no_chdir => 1, |
| wanted => sub { |
| return unless -f $_; |
| my $file = basename $File::Find::name; |
| return unless $file =~ /$core_pat/o; |
| my $core = $File::Find::name; |
| if (exists $core_files{$core} && $core_files{$core} == -M $core) { |
| # we have seen this core file before the start of the test |
| info "an old core file has been found: $core"; |
| } |
| else { |
| my $oh = oh(); |
| my $again = $times++ ? "again" : ""; |
| error "oh $oh, server dumped core $again"; |
| error "for stacktrace, run: gdb $vars->{httpd} -core $core"; |
| } |
| }}, $vars->{top_dir}); |
| } |
| |
| # warn the user that there is a core file before the tests |
| # start. suggest to delete it before proceeding or a false alarm can |
| # be generated at the end of the test routine run. |
| sub warn_core { |
| my $self = shift; |
| my $vars = $self->{test_config}->{vars}; |
| %core_files = (); # reset global |
| |
| # no core files dropped on win32 |
| return if Apache::TestConfig::WIN32; |
| |
| finddepth(sub { |
| return unless -f $_; |
| return unless /$core_pat/o; |
| my $core = "$File::Find::dir/$_"; |
| info "consider removing an old $core file before running tests"; |
| # remember the timestamp of $core so we can check if it's the |
| # old core file at the end of the run and not complain then |
| $core_files{$core} = -M $core; |
| }, $vars->{top_dir}); |
| } |
| |
| # catch any attempts to ./t/TEST the tests as root user |
| |
| sub check_runtime_user { |
| my $self = shift; |
| |
| return if Apache::TestConfig::WINFU; |
| |
| my $user = getpwuid($>) || ''; |
| |
| if ($user eq 'root') { |
| error "Apache cannot spawn child processes as root, therefore the test suite must be run as a non-privileged user."; |
| exit_perl(1); |
| } |
| |
| return 1; |
| } |
| |
| sub run_request { |
| my($test_config, $opts) = @_; |
| |
| my @args = (%{ $opts->{header} }, %{ $opts->{req_args} }); |
| |
| my($request, $url) = ("", ""); |
| |
| for (@request_opts) { |
| next unless exists $opts->{$_}; |
| $url = $opts->{$_} if $opts->{$_}; |
| $request = join $request ? '_' : '', $request, $_; |
| } |
| |
| if ($request) { |
| my $method = \&{"Apache::TestRequest::\U$request"}; |
| my $res = $method->($url, @args); |
| print Apache::TestRequest::to_string($res); |
| } |
| } |
| |
| sub opt_clean { |
| my($self, $level) = @_; |
| my $test_config = $self->{test_config}; |
| $test_config->server->stop; |
| $test_config->clean($level); |
| 1; |
| } |
| |
| sub opt_ping { |
| my($self) = @_; |
| |
| my $test_config = $self->{test_config}; |
| my $server = $test_config->server; |
| my $pid = $server->ping; |
| my $name = $server->{name}; |
| # support t/TEST -ping=block -run ... |
| my $exit = not $self->{opts}->{'run-tests'}; |
| |
| if ($pid) { |
| if ($pid == -1) { |
| error "port $test_config->{vars}->{port} is in use, ". |
| "but cannot determine server pid"; |
| } |
| else { |
| my $version = $server->{version}; |
| warning "server $name running (pid=$pid, version=$version)"; |
| } |
| return $exit; |
| } |
| |
| if (exists $self->{opts}->{ping} && $self->{opts}->{ping} eq 'block') { |
| $server->wait_till_is_up(STARTUP_TIMEOUT); |
| } |
| else { |
| warning "no server is running on $name"; |
| exit_perl(0); |
| } |
| |
| return $exit; #means call exit() if true |
| } |
| |
| sub test_inc { |
| map { "$_/Apache-Test/lib" } qw(. ..); |
| } |
| |
| sub set_perl5lib { |
| $ENV{PERL5LIB} = join $Config{path_sep}, shift->test_inc(); |
| } |
| |
| sub set_perldb_opts { |
| my $config = shift->{test_config}; |
| my $file = catfile $config->{vars}->{t_logs}, 'perldb.out'; |
| $config->genfile($file); #mark for -clean |
| $ENV{PERLDB_OPTS} = "NonStop frame=4 AutoTrace LineInfo=$file"; |
| warning "perldb log is t/logs/perldb.out"; |
| } |
| |
| sub opt_debug { |
| my $self = shift; |
| my $server = $self->{server}; |
| |
| my $opts = $self->{opts}; |
| my $debug_opts = {}; |
| |
| for (qw(debugger breakpoint)) { |
| $debug_opts->{$_} = $opts->{$_}; |
| } |
| |
| if (my $db = $opts->{debugger}) { |
| if ($db =~ s/^perl=?//) { |
| $opts->{'run-tests'} = 1; |
| $self->start; #if not already running |
| $self->set_perl5lib; |
| $self->set_perldb_opts if $db eq 'nostop'; |
| system $^X, '-MApache::TestPerlDB', '-d', @{ $self->{tests} }; |
| $self->stop; |
| return 1; |
| } |
| elsif ($db =~ s/^lwp[=:]?//) { |
| $ENV{APACHE_TEST_DEBUG_LWP} = $db || 1; |
| $opts->{verbose} = 1; |
| return 0; |
| } |
| } |
| |
| $server->stop; |
| $server->start_debugger($debug_opts); |
| 1; |
| } |
| |
| sub opt_help { |
| my $self = shift; |
| |
| print <<EOM; |
| usage: TEST [options ...] |
| where options include: |
| EOM |
| |
| for (sort keys %usage){ |
| printf " -%-13s %s\n", $_, $usage{$_}; |
| } |
| |
| print "\n configuration options:\n"; |
| |
| Apache::TestConfig->usage; |
| 1; |
| } |
| |
| # generate t/TEST script (or a different filename) which will drive |
| # Apache::TestRun |
| sub generate_script { |
| my ($class, @opts) = @_; |
| |
| my %opts = (); |
| |
| # back-compat |
| if (@opts == 1) { |
| $opts{file} = $opts[0]; |
| } |
| else { |
| %opts = @opts; |
| $opts{file} ||= catfile 't', 'TEST'; |
| } |
| |
| my $body = "BEGIN { eval { require blib && blib->import; } }\n"; |
| |
| my %args = @Apache::TestMM::Argv; |
| while (my($k, $v) = each %args) { |
| $v =~ s/\|/\\|/g; |
| $body .= "\n\$Apache::TestConfig::Argv{'$k'} = q|$v|;\n"; |
| } |
| |
| my $header = Apache::TestConfig->perlscript_header; |
| |
| $body .= join "\n", |
| $header, "use $class ();"; |
| |
| if (my $report = $opts{bugreport}) { |
| $body .= "\n\npackage $class;\n" . |
| "sub bug_report { print '$report' }\n\n"; |
| } |
| |
| $body .= "$class->new->run(\@ARGV);"; |
| |
| Apache::Test::basic_config()->write_perlscript($opts{file}, |
| $body); |
| } |
| |
| # in idiomatic perl functions return 1 on success and 0 on |
| # failure. Shell expects the opposite behavior. So this function |
| # reverses the status. |
| sub exit_perl { |
| exit_shell $_[0] ? 0 : 1; |
| } |
| |
| # expects shell's exit status values (0==success) |
| sub exit_shell { |
| # require Carp; |
| # Carp::cluck('exiting'); |
| CORE::exit $_[0]; |
| } |
| |
| 1; |
| |
| __END__ |
| |
| =head1 NAME |
| |
| Apache::TestRun - Run the test suite |
| |
| =head1 SYNOPSIS |
| |
| |
| =head1 DESCRIPTION |
| |
| The C<Apache::TestRun> package controls the configuration and running |
| of the test suite. |
| |
| =head1 METHODS |
| |
| Several methods are sub-classable, if the default behavior should be |
| changed. |
| |
| =head2 C<bug_report> |
| |
| The C<bug_report()> method is executed when C<t/TEST> was executed |
| with the C<-bugreport> option, and C<make test> (or C<t/TEST>) |
| fail. Normally this is callback which you can use to tell the user how |
| to deal with the problem, e.g. suggesting to read some document or |
| email some details to someone who can take care of it. By default |
| nothing is executed. |
| |
| The C<-bugreport> option is needed so this feature won't become |
| annoying to developers themselves. It's automatically added to the |
| C<run_tests> target in F<Makefile>. So if you repeateadly have to test |
| your code, just don't use C<make test> but run C<t/TEST> |
| directly. Here is an example of a custom C<t/TEST> |
| |
| My::TestRun->new->run(@ARGV); |
| |
| package My::TestRun; |
| use base 'Apache::TestRun'; |
| |
| sub bug_report { |
| my $self = shift; |
| |
| print <<EOI; |
| +--------------------------------------------------------+ |
| | Please file a bug report: http://perl.apache.org/bugs/ | |
| +--------------------------------------------------------+ |
| EOI |
| } |
| |
| =head2 C<pre_configure> |
| |
| The C<pre_configure()> method is executed before the configuration for |
| C<Apache::Test> is generated. So if you need to adjust the setup |
| before I<httpd.conf> and other files are autogenerated, this is the |
| right place to do so. |
| |
| For example if you don't want to inherit a LoadModule directive for |
| I<mod_apreq.so> but to make sure that the local version is used, you |
| can sub-class C<Apache::TestRun> and override this method in |
| I<t/TEST.PL>: |
| |
| package My::TestRun; |
| use base 'Apache::TestRun'; |
| use Apache::TestConfig; |
| __PACKAGE__->new->run(@ARGV); |
| |
| sub pre_configure { |
| my $self = shift; |
| # Don't load an installed mod_apreq |
| Apache::TestConfig::autoconfig_skip_module_add('mod_apreq.c'); |
| |
| $self->SUPER::pre_configure(); |
| } |
| |
| Notice that the extension is I<.c>, and not I<.so>. |
| |
| Don't forget to run the super class' c<pre_configure()> method. |
| |
| |
| |
| =head2 C<new_test_config> |
| |
| META: to be completed |
| |
| =cut |
