home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / TestRun.pm < prev    next >
Encoding:
Perl POD Document  |  2004-08-12  |  45.3 KB  |  1,537 lines
  1. # Copyright 2001-2004 The Apache Software Foundation
  2. #
  3. # Licensed under the Apache License, Version 2.0 (the "License");
  4. # you may not use this file except in compliance with the License.
  5. # You may obtain a copy of the License at
  6. #
  7. #     http://www.apache.org/licenses/LICENSE-2.0
  8. #
  9. # Unless required by applicable law or agreed to in writing, software
  10. # distributed under the License is distributed on an "AS IS" BASIS,
  11. # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  12. # See the License for the specific language governing permissions and
  13. # limitations under the License.
  14. #
  15. package Apache::TestRun;
  16.  
  17. use strict;
  18. use warnings FATAL => 'all';
  19.  
  20. use Apache::Test ();
  21. use Apache::TestMM ();
  22. use Apache::TestConfig ();
  23. use Apache::TestConfigC ();
  24. use Apache::TestRequest ();
  25. use Apache::TestHarness ();
  26. use Apache::TestTrace;
  27.  
  28. use Cwd;
  29. use ExtUtils::MakeMaker;
  30. use File::Find qw(finddepth);
  31. use File::Path;
  32. use File::Spec::Functions qw(catfile catdir canonpath);
  33. use File::Basename qw(basename dirname);
  34. use Getopt::Long qw(GetOptions);
  35. use Config;
  36.  
  37. use constant IS_APACHE_TEST_BUILD => Apache::TestConfig::IS_APACHE_TEST_BUILD;
  38.  
  39. use constant STARTUP_TIMEOUT => 300; # secs (good for extreme debug cases)
  40.  
  41. use subs qw(exit_shell exit_perl);
  42.  
  43. my $orig_command;
  44. my $orig_cwd;
  45.  
  46. my %core_files  = ();
  47. my %original_t_perms = ();
  48.  
  49. my @std_run      = qw(start-httpd run-tests stop-httpd);
  50. my @others       = qw(verbose configure clean help ssl http11 bugreport 
  51.                       save no-httpd);
  52. my @flag_opts    = (@std_run, @others);
  53. my @string_opts  = qw(order trace);
  54. my @ostring_opts = qw(proxy ping);
  55. my @debug_opts   = qw(debug);
  56. my @num_opts     = qw(times);
  57. my @list_opts    = qw(preamble postamble breakpoint);
  58. my @hash_opts    = qw(header);
  59. my @help_opts    = qw(clean help);
  60. my @request_opts = qw(get post head);
  61.  
  62. my @exit_opts_no_need_httpd = (@help_opts);
  63. my @exit_opts_need_httpd    = (@debug_opts, qw(ping));
  64.  
  65. my %usage = (
  66.    'start-httpd'     => 'start the test server',
  67.    'run-tests'       => 'run the tests',
  68.    'times=N'         => 'repeat the tests N times',
  69.    'order=mode'      => 'run the tests in one of the modes: ' .
  70.                         '(repeat|rotate|random|SEED)',
  71.    'stop-httpd'      => 'stop the test server',
  72.    'no-httpd'        => 'run the tests without configuring or starting httpd',
  73.    'verbose[=1]'     => 'verbose output',
  74.    'configure'       => 'force regeneration of httpd.conf ' .
  75.                         ' (tests will not be run)',
  76.    'clean'           => 'remove all generated test files',
  77.    'help'            => 'display this message',
  78.    'bugreport'       => 'print the hint how to report problems',
  79.    'preamble'        => 'config to add at the beginning of httpd.conf',
  80.    'postamble'       => 'config to add at the end of httpd.conf',
  81.    'ping[=block]'    => 'test if server is running or port in use',
  82.    'debug[=name]'    => 'start server under debugger name (gdb, ddd, etc.)',
  83.    'breakpoint=bp'   => 'set breakpoints (multiply bp can be set)',
  84.    'header'          => "add headers to (" .
  85.                          join('|', @request_opts) . ") request",
  86.    'http11'          => 'run all tests with HTTP/1.1 (keep alive) requests',
  87.    'ssl'             => 'run tests through ssl',
  88.    'proxy'           => 'proxy requests (default proxy is localhost)',
  89.    'trace=T'         => 'change tracing default to: warning, notice, ' .
  90.                         'info, debug, ...',
  91.    'save'            => 'save test paramaters into Apache::TestConfigData',
  92.    (map { $_, "\U$_\E url" } @request_opts),
  93. );
  94.  
  95. sub fixup {
  96.     #make sure we use an absolute path to perl
  97.     #else Test::Harness uses the perl in our PATH
  98.     #which might not be the one we want
  99.     $^X = $Config{perlpath} unless -e $^X;
  100. }
  101.  
  102. # if the test suite was aborted because of a user-error we don't want
  103. # to call the bugreport and invite users to submit a bug report -
  104. # after all it's a user error. but we still want the program to fail,
  105. # so raise this flag in such a case.
  106. my $user_error = 0;
  107. sub user_error {
  108.     my $self = shift;
  109.     $user_error = shift if @_;
  110.     $user_error;
  111. }
  112.  
  113. sub new {
  114.     my $class = shift;
  115.  
  116.     my $self = bless {
  117.         tests => [],
  118.         @_,
  119.     }, $class;
  120.  
  121.     $self->fixup;
  122.  
  123.     $self;
  124. }
  125.  
  126. #split arguments into test files/dirs and options
  127. #take extra care if -e, the file matches /\.t$/
  128. #                if -d, the dir contains .t files
  129. #so we dont slurp arguments that are not tests, example:
  130. # httpd $HOME/apache-2.0/bin/httpd
  131.  
  132. sub split_test_args {
  133.     my($self) = @_;
  134.  
  135.     my(@tests);
  136.     my $top_dir = $self->{test_config}->{vars}->{top_dir};
  137.     my $t_dir = $self->{test_config}->{vars}->{t_dir};
  138.  
  139.     my $argv = $self->{argv};
  140.     my @leftovers = ();
  141.     for (@$argv) {
  142.         my $arg = $_;
  143.         # need the t/ (or t\) for stat-ing, but don't want to include
  144.         # it in test output
  145.         $arg =~ s@^(?:\.[\\/])?t[\\/]@@;
  146.         my $file = catfile $t_dir, $arg;
  147.         if (-d $file and $_ ne '/') {
  148.             my @files = <$file/*.t>;
  149.             my $remove = catfile $top_dir, "";
  150.             if (@files) {
  151.                 push @tests, map { s,^\Q$remove,,; $_ } @files;
  152.                 next;
  153.             }
  154.         }
  155.         else {
  156.             if ($file =~ /\.t$/ and -e $file) {
  157.                 push @tests, "t/$arg";
  158.                 next;
  159.             }
  160.             elsif (-e "$file.t") {
  161.                 push @tests, "t/$arg.t";
  162.                 next;
  163.             }
  164.             elsif (/^[\d.]+$/) {
  165.                 my @t = $_;
  166.                 #support range of subtests: t/TEST t/foo/bar 60..65
  167.                 if (/^(\d+)\.\.(\d+)$/) {
  168.                     @t =  $1..$2;
  169.                 }
  170.  
  171.                 push @{ $self->{subtests} }, @t;
  172.                 next;
  173.             }
  174.         }
  175.         push @leftovers, $_;
  176.     }
  177.  
  178.     $self->{tests} = [ map { canonpath($_) } @tests ];
  179.     $self->{argv}  = \@leftovers;
  180. }
  181.  
  182. sub die_on_invalid_args {
  183.     my($self) = @_;
  184.  
  185.     # at this stage $self->{argv} should be empty
  186.     my @invalid_argv = @{ $self->{argv} };
  187.     if (@invalid_argv) {
  188.         error "unknown opts or test names: @invalid_argv\n" .
  189.             "-help will list options\n";
  190.         exit_perl 0;
  191.     }
  192.  
  193. }
  194.  
  195. sub passenv {
  196.     my $passenv = Apache::TestConfig->passenv;
  197.     for (keys %$passenv) {
  198.         return 1 if $ENV{$_};
  199.     }
  200.     0;
  201. }
  202.  
  203. sub getopts {
  204.     my($self, $argv) = @_;
  205.  
  206.     local *ARGV = $argv;
  207.     my(%opts, %vopts, %conf_opts);
  208.  
  209.     # a workaround to support -verbose and -verbose=0|1
  210.     # $Getopt::Long::VERSION > 2.26 can use the "verbose:1" rule
  211.     # but we have to support older versions as well
  212.     @ARGV = grep defined, 
  213.         map {/-verbose=(\d)/ ? ($1 ? '-verbose' : undef) : $_ } @ARGV;
  214.  
  215.     # permute      : optional values can come before the options
  216.     # pass_through : all unknown things are to be left in @ARGV
  217.     Getopt::Long::Configure(qw(pass_through permute));
  218.  
  219.     # grab from @ARGV only the options that we expect
  220.     GetOptions(\%opts, @flag_opts, @help_opts,
  221.                (map "$_:s", @debug_opts, @request_opts, @ostring_opts),
  222.                (map "$_=s", @string_opts),
  223.                (map "$_=i", @num_opts),
  224.                (map { ("$_=s", $vopts{$_} ||= []) } @list_opts),
  225.                (map { ("$_=s", $vopts{$_} ||= {}) } @hash_opts));
  226.  
  227.     $opts{$_} = $vopts{$_} for keys %vopts;
  228.  
  229.     # separate configuration options and test files/dirs
  230.     my $req_wanted_args = Apache::TestRequest::wanted_args();
  231.     my @argv = ();
  232.     my %req_args = ();
  233.     while (@ARGV) {
  234.         my $val = shift @ARGV;
  235.         if ($val =~ /^--?(.+)/) { # must have a leading - or --
  236.             my $key = lc $1;
  237.             # a known config option?
  238.             if (exists $Apache::TestConfig::Usage{$key}) {
  239.                 $conf_opts{$key} = shift @ARGV;
  240.                 next;
  241.             } # a TestRequest config option?
  242.             elsif (exists $req_wanted_args->{$key}) {
  243.                 $req_args{$key} = shift @ARGV;
  244.                 next;
  245.             }
  246.         }
  247.         # to be processed later
  248.         push @argv, $val;
  249.     }
  250.  
  251.     # fixup the filepath options on win32 (spaces, short names, etc.)
  252.     if (Apache::TestConfig::WIN32) {
  253.         for my $key (keys %conf_opts) {
  254.             next unless Apache::TestConfig::conf_opt_is_a_filepath($key);
  255.             next unless -e $conf_opts{$key};
  256.             $conf_opts{$key} = Win32::GetShortPathName($conf_opts{$key});
  257.         }
  258.     }
  259.  
  260.     $opts{req_args} = \%req_args;
  261.  
  262.     # only test files/dirs if any at all are left in argv
  263.     $self->{argv} = \@argv;
  264.  
  265.     # force regeneration of httpd.conf if commandline args want to
  266.     # modify it. configure_opts() has more checks to decide whether to
  267.     # reconfigure or not.
  268.     # XXX: $self->passenv() is already tested in need_reconfiguration()
  269.     $self->{reconfigure} = $opts{configure} ||
  270.       (grep { $opts{$_}->[0] } qw(preamble postamble)) ||
  271.         (grep { $Apache::TestConfig::Usage{$_} } keys %conf_opts ) ||
  272.           $self->passenv() || (! -e 't/conf/httpd.conf');
  273.  
  274.     if (exists $opts{debug}) {
  275.         $opts{debugger} = $opts{debug};
  276.         $opts{debug} = 1;
  277.     }
  278.  
  279.     if ($opts{trace}) {
  280.         my %levels = map {$_ => 1} @Apache::TestTrace::Levels;
  281.         if (exists $levels{ $opts{trace} }) {
  282.             $Apache::TestTrace::Level = $opts{trace};
  283.             # propogate the override for the server-side.
  284.             # -trace overrides any previous APACHE_TEST_TRACE_LEVEL settings
  285.             $ENV{APACHE_TEST_TRACE_LEVEL} = $opts{trace};
  286.         }
  287.         else {
  288.             error "unknown trace level: $opts{trace}",
  289.                 "valid levels are: @Apache::TestTrace::Levels";
  290.             exit_perl 0;
  291.         }
  292.     }
  293.  
  294.     # breakpoint automatically turns the debug mode on
  295.     if (@{ $opts{breakpoint} }) {
  296.         $opts{debug} ||= 1;
  297.     }
  298.  
  299.     if ($self->{reconfigure}) {
  300.         $conf_opts{save} = 1;
  301.         delete $self->{reconfigure};
  302.     }
  303.     else {
  304.         $conf_opts{thaw} = 1;
  305.     }
  306.  
  307.     #propagate some values
  308.     for (qw(verbose)) {
  309.         $conf_opts{$_} = $opts{$_};
  310.     }
  311.  
  312.     $self->{opts} = \%opts;
  313.     $self->{conf_opts} = \%conf_opts;
  314. }
  315.  
  316. sub default_run_opts {
  317.     my $self = shift;
  318.     my($opts, $tests) = ($self->{opts}, $self->{tests});
  319.  
  320.     unless (grep { exists $opts->{$_} } @std_run, @request_opts) {
  321.         if (@$tests && $self->{server}->ping) {
  322.             # if certain tests are specified and server is running,
  323.             # dont restart
  324.             $opts->{'run-tests'} = 1;
  325.         }
  326.         else {
  327.             #default is server-server run-tests stop-server
  328.             $opts->{$_} = 1 for @std_run;
  329.         }
  330.     }
  331.  
  332.     $opts->{'run-tests'} ||= @$tests;
  333. }
  334.  
  335. my $parent_pid = $$;
  336. sub is_parent { $$ == $parent_pid }
  337.  
  338. my $caught_sig_int = 0;
  339.  
  340. sub install_sighandlers {
  341.     my $self = shift;
  342.  
  343.     my($server, $opts) = ($self->{server}, $self->{opts});
  344.  
  345.     $SIG{__DIE__} = sub {
  346.         return unless $_[0] =~ /^Failed/i; #dont catch Test::ok failures
  347.  
  348.         # _show_results() calls die() under a few conditions, such as
  349.         # when no tests are run or when tests fail.  make sure the message
  350.         # is propagated back to the user.
  351.         print $_[0] if (caller(1))[3]||'' eq 'Test::Harness::_show_results';
  352.  
  353.         $server->stop(1) if $opts->{'start-httpd'};
  354.         $server->failed_msg("error running tests");
  355.         exit_perl 0;
  356.     };
  357.  
  358.     $SIG{INT} = sub {
  359.         if ($caught_sig_int++) {
  360.             warning "\ncaught SIGINT";
  361.             exit_perl 0;
  362.         }
  363.         warning "\nhalting tests";
  364.         $server->stop if $opts->{'start-httpd'};
  365.         exit_perl 0;
  366.     };
  367.  
  368.     #try to make sure we scan for core no matter what happens
  369.     #must eval "" to "install" this END block, otherwise it will
  370.     #always run, a subclass might not want that
  371.     eval 'END {
  372.         return unless is_parent(); # because of fork
  373.         $self ||=
  374.             Apache::TestRun->new(test_config => Apache::TestConfig->thaw);
  375.         {
  376.             local $?; # preserve the exit status
  377.             eval {
  378.                $self->scan_core;
  379.             };
  380.         }
  381.         $self->try_bug_report();
  382.     }';
  383.     die "failed: $@" if $@;
  384.  
  385. }
  386.  
  387. sub try_bug_report {
  388.     my $self = shift;
  389.     if ($? && !$self->user_error &&
  390.         $self->{opts}->{bugreport} && $self->can('bug_report')) {
  391.         $self->bug_report;
  392.     }
  393. }
  394.  
  395. #throw away cached config and start fresh
  396. sub refresh {
  397.     my $self = shift;
  398.     $self->opt_clean(1);
  399.     $self->{conf_opts}->{save} = delete $self->{conf_opts}->{thaw} || 1;
  400.     $self->{test_config} = $self->new_test_config()->httpd_config;
  401.     $self->{server} = $self->{test_config}->server;
  402. }
  403.  
  404. sub configure_opts {
  405.     my $self = shift;
  406.     my $save = shift;
  407.     my $refreshed = 0;
  408.  
  409.     my($test_config, $opts) = ($self->{test_config}, $self->{opts});
  410.  
  411.     $test_config->{vars}->{scheme} =
  412.       $opts->{ssl} ? 'https' :
  413.         $self->{conf_opts}->{scheme} || 'http';
  414.  
  415.     if ($opts->{http11}) {
  416.         $ENV{APACHE_TEST_HTTP11} = 1;
  417.     }
  418.  
  419.     # unless we are already reconfiguring, check for .conf.in files changes
  420.     if (!$$save &&
  421.         (my @reasons =
  422.          $self->{test_config}->need_reconfiguration($self->{conf_opts}))) {
  423.         warning "forcing re-configuration:";
  424.         warning "\t- $_." for @reasons;
  425.         unless ($refreshed) {
  426.             $self->refresh;
  427.             $refreshed = 1;
  428.             $test_config = $self->{test_config};
  429.         }
  430.     }
  431.  
  432.     # unless we are already reconfiguring, check for -proxy
  433.     if (!$$save && exists $opts->{proxy}) {
  434.         my $max = $test_config->{vars}->{maxclients};
  435.         $opts->{proxy} ||= 'on';
  436.  
  437.         #if config is cached and MaxClients == 1, must reconfigure
  438.         if (!$$save and $opts->{proxy} eq 'on' and $max == 1) {
  439.             $$save = 1;
  440.             warning "server is reconfigured for proxy";
  441.             unless ($refreshed) {
  442.                 $self->refresh;
  443.                 $refreshed = 1;
  444.                 $test_config = $self->{test_config};
  445.             }
  446.         }
  447.  
  448.         $test_config->{vars}->{proxy} = $opts->{proxy};
  449.     }
  450.     else {
  451.         $test_config->{vars}->{proxy} = 'off';
  452.     }
  453.  
  454.     return unless $$save;
  455.  
  456.     my $preamble  = sub { shift->preamble($opts->{preamble}) };
  457.     my $postamble = sub { shift->postamble($opts->{postamble}) };
  458.  
  459.     $test_config->preamble_register($preamble);
  460.     $test_config->postamble_register($postamble);
  461. }
  462.  
  463. sub pre_configure { }
  464.  
  465. sub configure {
  466.     my $self = shift;
  467.  
  468.     if ($self->{opts}->{'no-httpd'}) {
  469.         warning "skipping httpd configuration";
  470.         return;
  471.     }
  472.  
  473.     # create the conf dir as early as possible
  474.     $self->{test_config}->prepare_t_conf();
  475.  
  476.     my $save = \$self->{conf_opts}->{save};
  477.     $self->configure_opts($save);
  478.  
  479.     my $config = $self->{test_config};
  480.     unless ($$save) {
  481.         my $addr = \$config->{vars}->{remote_addr};
  482.         my $remote_addr = $config->our_remote_addr;
  483.         unless ($$addr eq $remote_addr) {
  484.             warning "local ip address has changed, updating config cache";
  485.             $$addr = $remote_addr;
  486.         }
  487.         #update minor changes to cached config
  488.         #without complete regeneration
  489.         #for example this allows switching between
  490.         #'t/TEST' and 't/TEST -ssl'
  491.         $config->sync_vars(qw(scheme proxy remote_addr));
  492.         return;
  493.     }
  494.  
  495.     my $test_config = $self->{test_config};
  496.     $test_config->sslca_generate;
  497.     $test_config->generate_ssl_conf if $self->{opts}->{ssl};
  498.     $test_config->cmodules_configure;
  499.     $test_config->generate_httpd_conf;
  500.     $test_config->save;
  501.  
  502.     # custom config save if
  503.     # 1) requested to save
  504.     # 2) no saved config yet
  505.     if ($self->{opts}->{save} or
  506.         !Apache::TestConfig::custom_config_exists()) {
  507.         $test_config->custom_config_save($self->{conf_opts});
  508.     }
  509. }
  510.  
  511. sub try_exit_opts {
  512.     my $self = shift;
  513.     my @opts = @_;
  514.  
  515.     for (@opts) {
  516.         next unless exists $self->{opts}->{$_};
  517.         my $method = "opt_$_";
  518.         my $rc = $self->$method();
  519.         exit_perl $rc if $rc;
  520.     }
  521.  
  522.     if ($self->{opts}->{'stop-httpd'}) {
  523.         my $ok = 1;
  524.         if ($self->{server}->ping) {
  525.             $ok = $self->{server}->stop;
  526.             $ok = $ok < 0 ? 0 : 1; # adjust to 0/1 logic
  527.         }
  528.         else {
  529.             warning "server $self->{server}->{name} is not running";
  530.             # cleanup a stale httpd.pid file if found
  531.             my $t_logs  = $self->{test_config}->{vars}->{t_logs};
  532.             my $pid_file = catfile $t_logs, "httpd.pid";
  533.             unlink $pid_file if -e $pid_file;
  534.         }
  535.         exit_perl $ok;
  536.     }
  537. }
  538.  
  539. sub start {
  540.     my $self = shift;
  541.  
  542.     my $opts = $self->{opts};
  543.     my $server = $self->{server};
  544.  
  545.     #if t/TEST -d is running make sure we don't try to stop/start the server
  546.     my $file = $server->debugger_file;
  547.     if (-e $file and $opts->{'start-httpd'}) {
  548.         if ($server->ping) {
  549.             warning "server is running under the debugger, " .
  550.                 "defaulting to -run";
  551.             $opts->{'start-httpd'} = $opts->{'stop-httpd'} = 0;
  552.         }
  553.         else {
  554.             warning "removing stale debugger note: $file";
  555.             unlink $file;
  556.         }
  557.     }
  558.  
  559.     $self->adjust_t_perms();
  560.  
  561.     if ($opts->{'start-httpd'}) {
  562.         exit_perl 0 unless $server->start;
  563.     }
  564.     elsif ($opts->{'run-tests'}) {
  565.         my $is_up = $server->ping
  566.             || (exists $self->{opts}->{ping}
  567.                 && $self->{opts}->{ping}  eq 'block'
  568.                 && $server->wait_till_is_up(STARTUP_TIMEOUT));
  569.         unless ($is_up) {
  570.             error "server is not ready yet, try again.";
  571.             exit_perl 0;
  572.         }
  573.     }
  574. }
  575.  
  576. sub run_tests {
  577.     my $self = shift;
  578.  
  579.     my $test_opts = {
  580.         verbose => $self->{opts}->{verbose},
  581.         tests   => $self->{tests},
  582.         times   => $self->{opts}->{times},
  583.         order   => $self->{opts}->{order},
  584.         subtests => $self->{subtests} || [],
  585.     };
  586.  
  587.     if (grep { exists $self->{opts}->{$_} } @request_opts) {
  588.         run_request($self->{test_config}, $self->{opts});
  589.     }
  590.     else {
  591.         Apache::TestHarness->run($test_opts)
  592.             if $self->{opts}->{'run-tests'};
  593.     }
  594. }
  595.  
  596. sub stop {
  597.     my $self = shift;
  598.  
  599.     $self->restore_t_perms;
  600.  
  601.     return $self->{server}->stop if $self->{opts}->{'stop-httpd'};
  602. }
  603.  
  604. sub new_test_config {
  605.     my $self = shift;
  606.  
  607.     Apache::TestConfig->new($self->{conf_opts});
  608. }
  609.  
  610. sub set_ulimit_via_sh {
  611.     return if Apache::TestConfig::WINFU;
  612.     return if $ENV{APACHE_TEST_ULIMIT_SET};
  613.  
  614.     # only root can allow unlimited core dumps on Solaris (8 && 9?)
  615.     if (Apache::TestConfig::SOLARIS) {
  616.         my $user = getpwuid($>) || '';
  617.         if ($user ne 'root') {
  618.             warning "Skipping 'set unlimited ulimit for coredumps', " .
  619.                 "since we are running as a non-root user on Solaris";
  620.             return;
  621.         }
  622.     }
  623.  
  624.     my $binsh = '/bin/sh';
  625.     return unless -e $binsh;
  626.     $ENV{APACHE_TEST_ULIMIT_SET} = 1;
  627.  
  628.     my $sh = Symbol::gensym();
  629.     open $sh, "echo ulimit -a | $binsh|" or die;
  630.     local $_;
  631.     while (<$sh>) {
  632.         if (/^core.*unlimited$/) {
  633.             #already set to unlimited
  634.             $ENV{APACHE_TEST_ULIMIT_SET} = 1;
  635.             return;
  636.         }
  637.     }
  638.     close $sh;
  639.  
  640.     $orig_command = "ulimit -c unlimited; $orig_command";
  641.     warning "setting ulimit to allow core files\n$orig_command";
  642.     exec $orig_command;
  643.     die "exec $orig_command has failed"; # shouldn't be reached
  644. }
  645.  
  646. sub set_ulimit {
  647.     my $self = shift;
  648.     #return if $self->set_ulimit_via_bsd_resource;
  649.     eval { $self->set_ulimit_via_sh };
  650. }
  651.  
  652. sub set_env {
  653.     #export some environment variables for t/modules/env.t
  654.     #(the values are unimportant)
  655.     $ENV{APACHE_TEST_HOSTNAME} = 'test.host.name';
  656.     $ENV{APACHE_TEST_HOSTTYPE} = 'z80';
  657. }
  658.  
  659. sub run {
  660.     my $self = shift;
  661.  
  662.     # assuming that test files are always in the same directory as the
  663.     # driving script, make it possible to run the test suite from any place
  664.     # use a full path, which will work after chdir (e.g. ./TEST)
  665.     $0 = File::Spec->rel2abs($0);
  666.     if (-e $0) {
  667.         my $top = dirname dirname $0;
  668.         chdir $top if $top and -d $top;
  669.     }
  670.  
  671.     # reconstruct argv, preserve multiwords args, eg 'PerlTrace all'
  672.     my $argv = join " ", map { /^-/ ? $_ : qq['$_'] } @ARGV;
  673.     $orig_command = "$^X $0 $argv";
  674.     $orig_cwd = Cwd::cwd();
  675.     $self->set_ulimit;
  676.     $self->set_env; #make sure these are always set
  677.  
  678.     $self->detect_relocation($orig_cwd);
  679.  
  680.     my(@argv) = @_;
  681.  
  682.     $self->getopts(\@argv);
  683.  
  684.     # must be called after getopts so the tracing will be set right
  685.     Apache::TestConfig::custom_config_load();
  686.  
  687.     $self->pre_configure();
  688.  
  689.     # can't setup the httpd-specific parts of the config object yet
  690.     $self->{test_config} = $self->new_test_config();
  691.  
  692.     $self->warn_core();
  693.  
  694.     $self->{server} = $self->{test_config}->server;
  695.  
  696.     local($SIG{__DIE__}, $SIG{INT});
  697.     $self->install_sighandlers;
  698.  
  699.     $self->try_exit_opts(@exit_opts_no_need_httpd);
  700.  
  701.     # httpd is found here (unless it was already configured before)
  702.     $self->{test_config}->httpd_config();
  703.  
  704.     $self->try_exit_opts(@exit_opts_need_httpd);
  705.  
  706.     if ($self->{opts}->{configure}) {
  707.         warning "cleaning out current configuration";
  708.         $self->opt_clean(1);
  709.     }
  710.  
  711.     # if configure() fails for some reason before it has flushed the
  712.     # config to a file, save it so -clean will be able to clean
  713.     unless ($self->{opts}->{clean}) {
  714.         eval { $self->configure };
  715.         if ($@) {
  716.             error "configure() has failed:\n$@";
  717.             warning "forcing Apache::TestConfig object save";
  718.             $self->{test_config}->save;
  719.             warning "run 't/TEST -clean' to clean up before continuing";
  720.             exit_perl 0;
  721.         }
  722.     }
  723.  
  724.     if ($self->{opts}->{configure}) {
  725.         warning "reconfiguration done";
  726.         exit_perl 1;
  727.     }
  728.  
  729.     $self->default_run_opts;
  730.  
  731.     $self->split_test_args;
  732.  
  733.     $self->die_on_invalid_args;
  734.  
  735.     $self->start unless $self->{opts}->{'no-httpd'};
  736.  
  737.     $self->run_tests;
  738.  
  739.     $self->stop unless $self->{opts}->{'no-httpd'};
  740. }
  741.  
  742. sub rerun {
  743.     $orig_cwd ||= Cwd::cwd();
  744.     chdir $orig_cwd;
  745.     warning "rerunning '$orig_command' with new config opts";
  746.     exec $orig_command;
  747.     die "exec $orig_command has failed"; # shouldn't be reached
  748. }
  749.  
  750.  
  751. # make it easy to move the whole distro w/o running
  752. # 't/TEST -clean' before moving. when moving the whole package,
  753. # the old cached config will stay, so we want to nuke it only if
  754. # we realize that it's no longer valid. we can't just check the
  755. # existance of the saved top_dir value, since the project may have
  756. # been copied and the old dir could be still there, but that's not
  757. # the one that we work in
  758. sub detect_relocation {
  759.     my($self, $cur_top_dir) = @_;
  760.  
  761.     my $config_file = catfile qw(t conf apache_test_config.pm);
  762.     return unless -e $config_file;
  763.  
  764.     my %inc = %INC;
  765.     eval { require "$config_file" };
  766.     %INC = %inc; # be stealth
  767.     warn($@), return if $@;
  768.  
  769.     my $cfg = 'apache_test_config'->new;
  770.  
  771.     # if the top_dir from saved config doesn't match the current
  772.     # top_dir, that means that the whole project was relocated to a
  773.     # different directory, w/o running t/TEST -clean first (in each
  774.     # directory with a test suite)
  775.     my $cfg_top_dir = $cfg->{vars}->{top_dir};
  776.     return unless $cfg_top_dir;
  777.     return if $cfg_top_dir eq $cur_top_dir;
  778.  
  779.     # if that's the case silently fixup the saved config to use the
  780.     # new paths, and force a complete cleanup. if we don't fixup the
  781.     # config files, the cleanup process won't be able to locate files
  782.     # to delete and re-configuration will fail
  783.     {
  784.         # in place editing
  785.         local @ARGV = $config_file;
  786.         local $^I = ".bak";  # Win32 needs a backup
  787.         while (<>) {
  788.             s{$cfg_top_dir}{$cur_top_dir}g;
  789.             print;
  790.         }
  791.         unlink $config_file . $^I;
  792.     }
  793.  
  794.     my $cleanup_cmd = "$^X $0 -clean";
  795.     warning "cleaning up the old config";
  796.     # XXX: do we care to check success?
  797.     system $cleanup_cmd;
  798.  
  799.     # XXX: I tried hard to accomplish that w/o starting a new process,
  800.     # but too many things get on the way, so for now just keep it as an
  801.     # external process, as it's absolutely transparent to the normal
  802.     # app-run
  803. }
  804.  
  805. my @oh = qw(jeez golly gosh darn shucks dangit rats nuts dangnabit crap);
  806. sub oh {
  807.     $oh[ rand scalar @oh ];
  808. }
  809.  
  810. #e.g. t/core or t/core.12499
  811. my $core_pat = '^core(\.\d+)?' . "\$";
  812.  
  813. # $self->scan_core_incremental([$only_top_dir])
  814. # normally would be called after each test
  815. # and since it updates the list of seen core files
  816. # scan_core() won't report these again
  817. # currently used in Apache::TestSmoke
  818. #
  819. # if $only_t_dir arg is true only the t_dir dir (t/) will be scanned
  820. sub scan_core_incremental {
  821.     my($self, $only_t_dir) = @_;
  822.     my $vars = $self->{test_config}->{vars};
  823.  
  824.     # no core files dropped on win32
  825.     return () if Apache::TestConfig::WIN32;
  826.  
  827.     if ($only_t_dir) {
  828.         require IO::Dir;
  829.         my @cores = ();
  830.         for (IO::Dir->new($vars->{t_dir})->read) {
  831.             next unless -f;
  832.             next unless /$core_pat/o;
  833.             my $core = catfile $vars->{t_dir}, $_;
  834.             next if exists $core_files{$core} &&
  835.                 $core_files{$core} == -M $core;
  836.             $core_files{$core} = -M $core;
  837.             push @cores, $core;
  838.         }
  839.         return @cores 
  840.             ? join "\n", "server dumped core, for stacktrace, run:",
  841.                 map { "gdb $vars->{httpd} -core $_" } @cores
  842.             : ();
  843.     }
  844.  
  845.     my @msg = ();
  846.     finddepth({ no_chdir => 1,
  847.                 wanted   => sub {
  848.         return unless -f $_;
  849.         my $file = basename $File::Find::name;
  850.         return unless $file =~ /$core_pat/o;
  851.         my $core = $File::Find::name;
  852.         unless (exists $core_files{$core} && $core_files{$core} == -M $core) {
  853.             # new core file!
  854.  
  855.             # XXX: could rename the file if it doesn't include the pid
  856.             # in its name (i.e., just called 'core', instead of 'core.365')
  857.  
  858.             # XXX: could pass the test name and rename the core file
  859.             # to use that name as a suffix, plus pid, time or some
  860.             # other unique identifier, in case the same test is run
  861.             # more than once and each time it caused a segfault
  862.             $core_files{$core} = -M $core;
  863.             push @msg, "server dumped core, for stacktrace, run:\n" .
  864.                 "gdb $vars->{httpd} -core $core";
  865.         }
  866.     }}, $vars->{top_dir});
  867.  
  868.     return @msg;
  869.  
  870. }
  871.  
  872. sub scan_core {
  873.     my $self = shift;
  874.     my $vars = $self->{test_config}->{vars};
  875.     my $times = 0;
  876.  
  877.     # no core files dropped on win32
  878.     return if Apache::TestConfig::WIN32;
  879.  
  880.     finddepth({ no_chdir => 1,
  881.                 wanted   => sub {
  882.         return unless -f $_;
  883.         my $file = basename $File::Find::name;
  884.         return unless $file =~ /$core_pat/o;
  885.         my $core = $File::Find::name;
  886.         if (exists $core_files{$core} && $core_files{$core} == -M $core) {
  887.             # we have seen this core file before the start of the test
  888.             info "an old core file has been found: $core";
  889.         }
  890.         else {
  891.             my $oh = oh();
  892.             my $again = $times++ ? "again" : "";
  893.             error "oh $oh, server dumped core $again";
  894.             error "for stacktrace, run: gdb $vars->{httpd} -core $core";
  895.         }
  896.     }}, $vars->{top_dir});
  897. }
  898.  
  899. # warn the user that there is a core file before the tests
  900. # start. suggest to delete it before proceeding or a false alarm can
  901. # be generated at the end of the test routine run.
  902. sub warn_core {
  903.     my $self = shift;
  904.     my $vars = $self->{test_config}->{vars};
  905.     %core_files = (); # reset global
  906.  
  907.     # no core files dropped on win32
  908.     return if Apache::TestConfig::WIN32;
  909.  
  910.     finddepth(sub {
  911.         return unless -f $_;
  912.         return unless /$core_pat/o;
  913.         my $core = "$File::Find::dir/$_";
  914.         info "consider removing an old $core file before running tests";
  915.         # remember the timestamp of $core so we can check if it's the
  916.         # old core file at the end of the run and not complain then
  917.         $core_files{$core} = -M $core;
  918.     }, $vars->{top_dir});
  919. }
  920.  
  921. # this function handles the cases when the test suite is run under
  922. # 'root':
  923. #
  924. # 1. When user 'bar' is chosen to run Apache with, files and dirs
  925. #    created by 'root' might be not writable/readable by 'bar'
  926. #
  927. # 2. when the source is extracted as user 'foo', and the chosen user
  928. #    to run Apache under is 'bar', in which case normally 'bar' won't
  929. #    have the right permissions to write into the fs created by 'foo'.
  930. #
  931. # We solve that by 'chown -R bar.bar t/' in a portable way.
  932. #
  933. # 3. If the parent directory is not rwx for the chosen user, that user
  934. #    won't be able to read/write the DocumentRoot. In which case we
  935. #    have nothing else to do, but to tell the user to fix the situation.
  936. #
  937. sub adjust_t_perms {
  938.     my $self = shift;
  939.  
  940.     return if Apache::TestConfig::WINFU;
  941.  
  942.     %original_t_perms = (); # reset global
  943.  
  944.     my $user = getpwuid($>) || '';
  945.     if ($user eq 'root') {
  946.         my $vars = $self->{test_config}->{vars};
  947.         my $user = $vars->{user};
  948.         my($uid, $gid) = (getpwnam($user))[2..3]
  949.             or die "Can't find out uid/gid of '$user'";
  950.  
  951.         warning "root mode: ". 
  952.             "changing the files ownership to '$user' ($uid:$gid)";
  953.         finddepth(sub {
  954.             $original_t_perms{$File::Find::name} = [(stat $_)[4..5]];
  955.             chown $uid, $gid, $_;
  956.         }, $vars->{t_dir});
  957.  
  958.         $self->check_perms($user, $uid, $gid);
  959.  
  960.         $self->become_nonroot($user, $uid, $gid);
  961.     }
  962. }
  963.  
  964. sub restore_t_perms {
  965.     my $self = shift;
  966.  
  967.     return if Apache::TestConfig::WINFU;
  968.  
  969.     if (%original_t_perms) {
  970.         warning "root mode: restoring the original files ownership";
  971.         my $vars = $self->{test_config}->{vars};
  972.         while (my($file, $ids) = each %original_t_perms) {
  973.             next unless -e $file; # files could be deleted
  974.             chown @$ids, $file;
  975.         }
  976.     }
  977. }
  978.  
  979. # this sub is executed from an external process only, since it
  980. # "sudo"'s into a uid/gid of choice
  981. sub run_root_fs_test {
  982.     my($uid, $gid, $dir) = @_;
  983.  
  984.     # first must change gid and egid ("$gid $gid" for an empty
  985.     # setgroups() call as explained in perlvar.pod)
  986.     my $groups = "$gid $gid";
  987.     $( = $) = $groups;
  988.     die "failed to change gid to $gid"
  989.         unless $( eq $groups && $) eq $groups;
  990.  
  991.     # only now can change uid and euid
  992.     $< = $> = $uid+0;
  993.     die "failed to change uid to $uid" unless $< == $uid && $> == $uid;
  994.  
  995.     my $file = catfile $dir, ".apache-test-file-$$-".time.int(rand);
  996.     eval "END { unlink q[$file] }";
  997.  
  998.     # unfortunately we can't run the what seems to be an obvious test:
  999.     # -r $dir && -w _ && -x _
  1000.     # since not all perl implementations do it right (e.g. sometimes
  1001.     # acls are ignored, at other times setid/gid change is ignored)
  1002.     # therefore we test by trying to attempt to read/write/execute
  1003.  
  1004.     # -w
  1005.     open TEST, ">$file" or die "failed to open $file: $!";
  1006.  
  1007.     # -x
  1008.     -f $file or die "$file cannot be looked up";
  1009.     close TEST;
  1010.  
  1011.     # -r
  1012.     opendir DIR, $dir or die "failed to open dir $dir: $!";
  1013.     defined readdir DIR or die "failed to read dir $dir: $!";
  1014.     close DIR;
  1015.  
  1016.     # all tests passed
  1017.     print "OK";
  1018. }
  1019.  
  1020. sub check_perms {
  1021.     my ($self, $user, $uid, $gid) = @_;
  1022.  
  1023.     # test that the base dir is rwx by the selected non-root user
  1024.     my $vars = $self->{test_config}->{vars};
  1025.     my $dir  = $vars->{t_dir};
  1026.     my $perl = Apache::TestConfig::shell_ready($vars->{perl});
  1027.  
  1028.     # find where Apache::TestRun was loaded from, so we load this
  1029.     # exact package from the external process
  1030.     my $inc = dirname dirname $INC{"Apache/TestRun.pm"};
  1031.     my $sub = "Apache::TestRun::run_root_fs_test";
  1032.     my $check = <<"EOI";
  1033. $perl -Mlib=$inc -MApache::TestRun -e 'eval { $sub($uid, $gid, q[$dir]) }';
  1034. EOI
  1035.     warning "testing whether '$user' is able to -rwx $dir\n$check\n";
  1036.  
  1037.     my $res = qx[$check] || '';
  1038.     warning "result: $res";
  1039.     unless ($res eq 'OK') {
  1040.         $self->user_error(1);
  1041.         #$self->restore_t_perms;
  1042.         error <<"EOI";
  1043. You are running the test suite under user 'root'.
  1044. Apache cannot spawn child processes as 'root', therefore
  1045. we attempt to run the test suite with user '$user' ($uid:$gid).
  1046. The problem is that the path (including all parent directories):
  1047.   $dir
  1048. must be 'rwx' by user '$user', so Apache can read and write under that
  1049. path.
  1050.  
  1051. There are several ways to resolve this issue. One is to move and
  1052. rebuild the distribution to '/tmp/' and repeat the 'make test'
  1053. phase. The other is not to run 'make test' as root (i.e. building
  1054. under your /home/user directory).
  1055.  
  1056. You can test whether some directory is suitable for 'make test' under
  1057. 'root', by running a simple test. For example to test a directory
  1058. '$dir', run:
  1059.  
  1060.   % $check
  1061. Only if the test prints 'OK', the directory is suitable to be used for
  1062. testing.
  1063. EOI
  1064.         skip_test_suite();
  1065.         exit_perl 0;
  1066.     }
  1067. }
  1068.  
  1069. # in case the client side creates any files after the initial chown
  1070. # adjustments we want the server side to be able to read/write them, so
  1071. # they better be with the same permissions. dropping root permissions
  1072. # and becoming the same user as the server side solves this problem.
  1073. sub become_nonroot {
  1074.     my ($self, $user, $uid, $gid) = @_;
  1075.  
  1076.     warning "the client side drops 'root' permissions and becomes '$user'";
  1077.  
  1078.     # first must change gid and egid ("$gid $gid" for an empty
  1079.     # setgroups() call as explained in perlvar.pod)
  1080.     my $groups = "$gid $gid";
  1081.     $( = $) = $groups;
  1082.     die "failed to change gid to $gid" unless $( eq $groups && $) eq $groups;
  1083.  
  1084.     # only now can change uid and euid
  1085.     $< = $> = $uid+0;
  1086.     die "failed to change uid to $uid" unless $< == $uid && $> == $uid;
  1087. }
  1088.  
  1089. sub run_request {
  1090.     my($test_config, $opts) = @_;
  1091.  
  1092.     my @args = (%{ $opts->{header} }, %{ $opts->{req_args} });
  1093.  
  1094.     my($request, $url) = ("", "");
  1095.  
  1096.     for (@request_opts) {
  1097.         next unless exists $opts->{$_};
  1098.         $url = $opts->{$_} if $opts->{$_};
  1099.         $request = join $request ? '_' : '', $request, $_;
  1100.     }
  1101.  
  1102.     if ($request) {
  1103.         my $method = \&{"Apache::TestRequest::\U$request"};
  1104.         my $res = $method->($url, @args);
  1105.         print Apache::TestRequest::to_string($res);
  1106.     }
  1107. }
  1108.  
  1109. sub opt_clean {
  1110.     my($self, $level) = @_;
  1111.     my $test_config = $self->{test_config};
  1112.     $test_config->server->stop;
  1113.     $test_config->clean($level);
  1114.     1;
  1115. }
  1116.  
  1117. sub opt_ping {
  1118.     my($self) = @_;
  1119.  
  1120.     my $test_config = $self->{test_config};
  1121.     my $server = $test_config->server;
  1122.     my $pid = $server->ping;
  1123.     my $name = $server->{name};
  1124.     # support t/TEST -ping=block -run ...
  1125.     my $exit = not $self->{opts}->{'run-tests'};
  1126.  
  1127.     if ($pid) {
  1128.         if ($pid == -1) {
  1129.             error "port $test_config->{vars}->{port} is in use, ".
  1130.                   "but cannot determine server pid";
  1131.         }
  1132.         else {
  1133.             my $version = $server->{version};
  1134.             warning "server $name running (pid=$pid, version=$version)";
  1135.         }
  1136.         return $exit;
  1137.     }
  1138.  
  1139.     if (exists $self->{opts}->{ping} && $self->{opts}->{ping} eq 'block') {
  1140.         $server->wait_till_is_up(STARTUP_TIMEOUT);
  1141.     }
  1142.     else {
  1143.         warning "no server is running on $name";
  1144.     }
  1145.  
  1146.     return $exit; #means call exit() if true
  1147. }
  1148.  
  1149. sub test_inc {
  1150.     map { "$_/Apache-Test/lib" } qw(. ..);
  1151. }
  1152.  
  1153. sub set_perl5lib {
  1154.     $ENV{PERL5LIB} = join $Config{path_sep}, shift->test_inc();
  1155. }
  1156.  
  1157. sub set_perldb_opts {
  1158.     my $config = shift->{test_config};
  1159.     my $file = catfile $config->{vars}->{t_logs}, 'perldb.out';
  1160.     $config->genfile($file); #mark for -clean
  1161.     $ENV{PERLDB_OPTS} = "NonStop frame=4 AutoTrace LineInfo=$file";
  1162.     warning "perldb log is t/logs/perldb.out";
  1163. }
  1164.  
  1165. sub opt_debug {
  1166.     my $self = shift;
  1167.     my $server = $self->{server};
  1168.  
  1169.     my $opts = $self->{opts};
  1170.     my $debug_opts = {};
  1171.  
  1172.     for (qw(debugger breakpoint)) {
  1173.         $debug_opts->{$_} = $opts->{$_};
  1174.     }
  1175.  
  1176.     if (my $db = $opts->{debugger}) {
  1177.         if ($db =~ s/^perl=?//) {
  1178.             $opts->{'run-tests'} = 1;
  1179.             $self->start; #if not already running
  1180.             $self->set_perl5lib;
  1181.             $self->set_perldb_opts if $db eq 'nostop';
  1182.             system $^X, '-MApache::TestPerlDB', '-d', @{ $self->{tests} };
  1183.             $self->stop;
  1184.             return 1;
  1185.         }
  1186.         elsif ($db =~ s/^lwp[=:]?//) {
  1187.             $ENV{APACHE_TEST_DEBUG_LWP} = $db || 1;
  1188.             $opts->{verbose} = 1;
  1189.             return 0;
  1190.         }
  1191.     }
  1192.  
  1193.     $server->stop;
  1194.     $server->start_debugger($debug_opts);
  1195.     1;
  1196. }
  1197.  
  1198. sub opt_help {
  1199.     my $self = shift;
  1200.  
  1201.     print <<EOM;
  1202. usage: TEST [options ...]
  1203.    where options include:
  1204. EOM
  1205.  
  1206.     for (sort keys %usage){
  1207.         printf "  -%-13s %s\n", $_, $usage{$_};
  1208.     }
  1209.  
  1210.     print "\n   configuration options:\n";
  1211.  
  1212.     Apache::TestConfig->usage;
  1213.     1;
  1214. }
  1215.  
  1216. # generate t/TEST script (or a different filename) which will drive
  1217. # Apache::TestRun
  1218. sub generate_script {
  1219.     my ($class, @opts) = @_;
  1220.  
  1221.     my %opts = ();
  1222.  
  1223.     # back-compat
  1224.     if (@opts == 1) {
  1225.         $opts{file} = $opts[0];
  1226.     }
  1227.     else {
  1228.         %opts = @opts;
  1229.         $opts{file} ||= catfile 't', 'TEST';
  1230.     }
  1231.  
  1232.     my $body = "BEGIN { eval { require blib; } }\n";
  1233.  
  1234.     $body .= Apache::TestConfig->modperl_2_inc_fixup;
  1235.  
  1236.     my %args = @Apache::TestMM::Argv;
  1237.     while (my($k, $v) = each %args) {
  1238.         $v =~ s/\|/\\|/g;
  1239.         $body .= "\n\$Apache::TestConfig::Argv{'$k'} = q|$v|;\n";
  1240.     }
  1241.  
  1242.     my $header = Apache::TestConfig->perlscript_header;
  1243.  
  1244.     $body .= join "\n",
  1245.         $header, "use $class ();";
  1246.  
  1247.     if (my $report = $opts{bugreport}) {
  1248.         $body .= "\n\npackage $class;\n" .
  1249.                  "sub bug_report { print '$report' }\n\n";
  1250.     }
  1251.  
  1252.     $body .= "$class->new->run(\@ARGV);";
  1253.  
  1254.     Apache::Test::basic_config()->write_perlscript($opts{file},
  1255.                                                    $body);
  1256. }
  1257.  
  1258. # in idiomatic perl functions return 1 on success and 0 on
  1259. # failure. Shell expects the opposite behavior. So this function
  1260. # reverses the status.
  1261. sub exit_perl {
  1262.     exit_shell $_[0] ? 0 : 1;
  1263. }
  1264.  
  1265. # expects shell's exit status values (0==success)
  1266. sub exit_shell {
  1267. #    require Carp;
  1268. #    Carp::cluck('exiting');
  1269.     CORE::exit $_[0];
  1270. }
  1271.  
  1272. # successfully abort the test suite execution (to allow automatic
  1273. # tools like CPAN.pm, to continue with installation).
  1274. #
  1275. # if a true value is passed, quit right away
  1276. # otherwise ask the user, if they may want to change their mind which
  1277. # will return them back to where they left
  1278. sub skip_test_suite {
  1279.     my $no_doubt = shift;
  1280.  
  1281.     print qq[
  1282.  
  1283. Running the test suite is important to make sure that the module that
  1284. you are about to install works on your system. If you choose not to
  1285. run the test suite and you have a problem using this module, make sure
  1286. to return and run this test suite before reporting any problems to the
  1287. developers of this module.
  1288.  
  1289. ];
  1290.     unless ($no_doubt) {
  1291.         my $default = 'No';
  1292.         my $prompt = 'Skip the test suite?';
  1293.         my $ans = ExtUtils::MakeMaker::prompt($prompt, $default);
  1294.         return if lc($ans) =~ /no/;
  1295.     }
  1296.  
  1297.     error "Skipping the test suite execution, while returning success status";
  1298.     exit_perl 1;
  1299. }
  1300.  
  1301. 1;
  1302.  
  1303. __END__
  1304.  
  1305. =head1 NAME
  1306.  
  1307. Apache::TestRun - Run the test suite
  1308.  
  1309. =head1 SYNOPSIS
  1310.  
  1311.  
  1312. =head1 DESCRIPTION
  1313.  
  1314. The C<Apache::TestRun> package controls the configuration and running
  1315. of the test suite.
  1316.  
  1317. =head1 METHODS
  1318.  
  1319. Several methods are sub-classable, if the default behavior should be
  1320. changed.
  1321.  
  1322. =head2 C<bug_report>
  1323.  
  1324. The C<bug_report()> method is executed when C<t/TEST> was executed
  1325. with the C<-bugreport> option, and C<make test> (or C<t/TEST>)
  1326. fail. Normally this is callback which you can use to tell the user how
  1327. to deal with the problem, e.g. suggesting to read some document or
  1328. email some details to someone who can take care of it. By default
  1329. nothing is executed.
  1330.  
  1331. The C<-bugreport> option is needed so this feature won't become
  1332. annoying to developers themselves. It's automatically added to the
  1333. C<run_tests> target in F<Makefile>. So if you repeateadly have to test
  1334. your code, just don't use C<make test> but run C<t/TEST>
  1335. directly. Here is an example of a custom C<t/TEST>
  1336.  
  1337.   My::TestRun->new->run(@ARGV);
  1338.   
  1339.   package My::TestRun;
  1340.   use base 'Apache::TestRun';
  1341.  
  1342.   sub bug_report {
  1343.       my $self = shift;
  1344.   
  1345.       print <<EOI;
  1346.   +--------------------------------------------------------+
  1347.   | Please file a bug report: http://perl.apache.org/bugs/ |
  1348.   +--------------------------------------------------------+
  1349.   EOI
  1350.   }
  1351.  
  1352. =head2 C<pre_configure>
  1353.  
  1354. The C<pre_configure()> method is executed before the configuration for
  1355. C<Apache::Test> is generated. So if you need to adjust the setup
  1356. before I<httpd.conf> and other files are autogenerated, this is the
  1357. right place to do so.
  1358.  
  1359. For example if you don't want to inherit a LoadModule directive for
  1360. I<mod_apreq.so> but to make sure that the local version is used, you
  1361. can sub-class C<Apache::TestRun> and override this method in
  1362. I<t/TEST.PL>:
  1363.  
  1364.   package My::TestRun;
  1365.   use base 'Apache::TestRun';
  1366.   use Apache::TestConfig;
  1367.   __PACKAGE__->new->run(@ARGV);
  1368.   
  1369.   sub pre_configure {
  1370.       my $self = shift;
  1371.       # Don't load an installed mod_apreq
  1372.       Apache::TestConfig::autoconfig_skip_module_add('mod_apreq.c');
  1373.   
  1374.       $self->SUPER::pre_configure();
  1375.   }
  1376.  
  1377. Notice that the extension is I<.c>, and not I<.so>.
  1378.  
  1379. Don't forget to run the super class' c<pre_configure()> method.
  1380.  
  1381.  
  1382.  
  1383. =head2 C<new_test_config>
  1384.  
  1385. META: to be completed
  1386.  
  1387.  
  1388.  
  1389. =head1 Persistent Custom Configuration
  1390.  
  1391. When C<Apache::Test> is first installed or used, it will save the
  1392. values of C<httpd>, C<apxs>, C<port>, C<user>, and C<group>, if set,
  1393. to a configuration file C<Apache::TestConfigData>.  This information
  1394. will then be used in setting these options for subsequent uses of
  1395. C<Apache-Test> unless temprorarily overridden, either by setting the
  1396. appropriate environment variable (C<APACHE_TEST_HTTPD>,
  1397. C<APACHE_TEST_APXS>, C<APACHE_TEST_PORT>, C<APACHE_TEST_USER>, and
  1398. C<APACHE_TEST_GROUP>) or by giving the relevant option (C<-httpd>,
  1399. C<-apxs>, C<-port>, C<-user>, and C<-group>) when the C<TEST> script
  1400. is run.
  1401.  
  1402. To avoid either using previous persistent configurations or saving
  1403. current configurations, set the C<APACHE_TEST_NO_STICKY_PREFERENCES>
  1404. environment variable to a true value.
  1405.  
  1406. Finally it's possible to permanently override the previously saved
  1407. options by passing C<L<-save|/Saving_Custom_Configuration_Options>>.
  1408.  
  1409. Here is the algorithm of how and when options are saved for the first
  1410. time and when they are used. We will use a few variables to simplify
  1411. the pseudo-code/pseudo-chart flow:
  1412.  
  1413. C<$config_exists> - custom configuration has already been saved, to
  1414. get this setting run C<custom_config_exists()>, which tests whether
  1415. either C<apxs> or C<httpd> values are set. It doesn't check for other
  1416. values, since all we need is C<apxs> or C<httpd> to get the test suite
  1417. running. custom_config_exists() checks in the following order
  1418. F<lib/Apache/TestConfigData.pm> (if during Apache-Test build) ,
  1419. F<~/.apache-test/Apache/TestConfigData.pm> and
  1420. F<Apache/TestConfigData.pm> in the perl's libraries.
  1421.  
  1422. C<$config_overriden> - that means that we have either C<apxs> or
  1423. C<httpd> values provided by user, via env vars or command line options.
  1424.  
  1425. =over
  1426.  
  1427. =item 1 Building Apache-Test or modperl-2.0 (or any other project that
  1428. bundles Apache-Test).
  1429.  
  1430.   1) perl Apache-Test/Makefile.PL
  1431.   (for bundles top-level Makefile.PL will run this as well)
  1432.  
  1433.   if $config_exists
  1434.       do nothing
  1435.   else
  1436.       create lib/Apache/TestConfigData.pm w/ empty config: {}
  1437.  
  1438.   2) make
  1439.  
  1440.   3) make test
  1441.  
  1442.   if $config_exists
  1443.       if $config_overriden
  1444.           override saved options (for those that were overriden)
  1445.       else
  1446.           use saved options
  1447.   else
  1448.       if $config_overriden
  1449.           save them in lib/Apache/TestConfigData.pm
  1450.           (which will be installed on 'make install')
  1451.       else
  1452.           - run interactive prompt for C<httpd> and optionally for C<apxs>
  1453.           - save the custom config in lib/Apache/TestConfigData.pm
  1454.           - restart the currently run program
  1455.  
  1456.   modperl-2.0 is a special case in (3). it always overrides 'httpd'
  1457.   and 'apxs' settings. Other settings like 'port', can be used from
  1458.   the saved config.
  1459.  
  1460.   4) make install
  1461.  
  1462.      if $config_exists only in lib/Apache/TestConfigData.pm
  1463.         it will be installed system-wide
  1464.      else
  1465.         nothing changes (since lib/Apache/TestConfigData.pm won't exist)
  1466.  
  1467. =item 2 Testing 3rd party modules (after Apache-Test was installed)
  1468.  
  1469. Notice that the following situation is quite possible:
  1470.  
  1471.   cd Apache-Test
  1472.   perl Makefile.PL && make install
  1473.  
  1474. so that Apache-Test was installed but no custom configuration saved
  1475. (since its C<make test> wasn't run). In which case the interactive
  1476. configuration should kick in (unless config options were passed) and
  1477. in any case saved once configured.
  1478.  
  1479. C<$custom_config_path> - perl's F<Apache/TestConfigData.pm> (at the
  1480. same location as F<Apache/TestConfig.pm>) if that area is writable by
  1481. that user (e.g. perl's lib is not owned by 'root'). If not, in
  1482. F<~/.apache-test/Apache/TestConfigData.pm>.
  1483.  
  1484.   1) perl Apache-Test/Makefile.PL
  1485.   2) make
  1486.   3) make test
  1487.  
  1488.   if $config_exists
  1489.       if $config_overriden
  1490.           override saved options (for those that were overriden)
  1491.       else
  1492.           use saved options
  1493.   else
  1494.       if $config_overriden
  1495.           save them in $custom_config_path
  1496.       else
  1497.           - run interactive prompt for C<httpd> and optionally for C<apxs>
  1498.           - save the custom config in $custom_config_path
  1499.           - restart the currently run program
  1500.  
  1501.   4) make install
  1502.  
  1503. =back
  1504.  
  1505.  
  1506.  
  1507. =head2 Saving Custom Configuration Options
  1508.  
  1509. If you want to override the existing custom configurations options to
  1510. C<Apache::TestConfigData>, use the C<-save> flag when running C<TEST>.
  1511.  
  1512. If you are running C<Apache::Test> as a user who does not have
  1513. permission to alter the system C<Apache::TestConfigData>, you can
  1514. place your own private configuration file F<TestConfigData.pm> under
  1515. C<$ENV{HOME}/.apache-test/Apache/>, which C<Apache::Test> will use, if
  1516. present. An example of such a configuration file is
  1517.  
  1518.   # file $ENV{HOME}/.apache-test/Apache/TestConfigData.pm
  1519.   package Apache::TestConfigData;
  1520.   use strict;
  1521.   use warnings;
  1522.   use vars qw($vars);
  1523.  
  1524.   $vars = {
  1525.       'group' => 'me',
  1526.       'user' => 'myself',
  1527.       'port' => '8529',
  1528.       'httpd' => '/usr/local/apache/bin/httpd',
  1529.  
  1530.   };
  1531.   1;
  1532.  
  1533.  
  1534.  
  1535.  
  1536. =cut
  1537.