File Coverage

blib/lib/Apache/TestRun.pm
Criterion Covered Total %
statement 60 616 9.7
branch 0 246 0.0
condition 0 121 0.0
subroutine 20 75 26.7
pod 2 47 4.3
total 82 1105 7.4


line stmt bran cond sub pod time code
1             # Licensed to the Apache Software Foundation (ASF) under one or more
2             # contributor license agreements. See the NOTICE file distributed with
3             # this work for additional information regarding copyright ownership.
4             # The ASF licenses this file to You under the Apache License, Version 2.0
5             # (the "License"); you may not use this file except in compliance with
6             # the License. You may obtain a copy of the License at
7             #
8             # http://www.apache.org/licenses/LICENSE-2.0
9             #
10             # Unless required by applicable law or agreed to in writing, software
11             # distributed under the License is distributed on an "AS IS" BASIS,
12             # WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13             # See the License for the specific language governing permissions and
14             # limitations under the License.
15             #
16             package Apache::TestRun;
17              
18 6     6   108 use strict;
  6         909  
  6         98  
19 6     6   91 use warnings FATAL => 'all';
  6         56  
  6         143  
20              
21 6     6   119 use Apache::Test ();
  6         54  
  6         58  
22 6     6   161 use Apache::TestMM ();
  6         64  
  6         83  
23 6     6   209 use Apache::TestConfig ();
  6         57  
  6         59  
24 6     6   406 use Apache::TestConfigC ();
  6         67  
  6         63  
25 6     6   119 use Apache::TestRequest ();
  6         59  
  6         60  
26 6     6   184 use Apache::TestHarness ();
  6         206  
  6         63  
27 6     6   115 use Apache::TestTrace;
  6         54  
  6         121  
28              
29 6     6   96 use Cwd;
  6         56  
  6         134  
30 6     6   281 use ExtUtils::MakeMaker;
  6         62  
  6         124  
31 6     6   98 use File::Find qw(finddepth);
  6         57  
  6         198  
32 6     6   121 use File::Path;
  6         54  
  6         114  
33 6     6   147 use File::Spec::Functions qw(catfile catdir canonpath);
  6         57  
  6         126  
34 6     6   95 use File::Basename qw(basename dirname);
  6         56  
  6         142  
35 6     6   179 use Getopt::Long qw(GetOptions);
  6         61  
  6         104  
36 6     6   96 use Config;
  6         54  
  6         100  
37              
38 6     6   92 use constant IS_APACHE_TEST_BUILD => Apache::TestConfig::IS_APACHE_TEST_BUILD;
  6         57  
  6         90  
39              
40 6     6   90 use constant STARTUP_TIMEOUT => 300; # secs (good for extreme debug cases)
  6         55  
  6         93  
41              
42 6     6   87 use subs qw(exit_shell exit_perl);
  6         52  
  6         92  
43              
44             my $orig_command;
45             my $orig_cwd;
46             my $orig_conf_opts;
47              
48             my %core_files = ();
49             my %original_t_perms = ();
50              
51             my @std_run = qw(start-httpd run-tests stop-httpd);
52             my @others = qw(verbose configure clean help ssl http11 bugreport
53             save no-httpd one-process);
54             my @flag_opts = (@std_run, @others);
55             my @string_opts = qw(order trace);
56             my @ostring_opts = qw(proxy ping);
57             my @debug_opts = qw(debug);
58             my @num_opts = qw(times);
59             my @list_opts = qw(preamble postamble breakpoint);
60             my @hash_opts = qw(header);
61             my @help_opts = qw(clean help);
62             my @request_opts = qw(get post head);
63              
64             my @exit_opts_no_need_httpd = (@help_opts);
65             my @exit_opts_need_httpd = (@debug_opts, qw(ping));
66              
67             my %usage = (
68                'start-httpd' => 'start the test server',
69                'run-tests' => 'run the tests',
70                'times=N' => 'repeat the tests N times',
71                'order=mode' => 'run the tests in one of the modes: ' .
72                                     '(repeat|rotate|random|SEED)',
73                'stop-httpd' => 'stop the test server',
74                'no-httpd' => 'run the tests without configuring or starting httpd',
75                'verbose[=1]' => 'verbose output',
76                'configure' => 'force regeneration of httpd.conf ' .
77                                     ' (tests will not be run)',
78                'clean' => 'remove all generated test files',
79                'help' => 'display this message',
80                'bugreport' => 'print the hint how to report problems',
81                'preamble' => 'config to add at the beginning of httpd.conf',
82                'postamble' => 'config to add at the end of httpd.conf',
83                'ping[=block]' => 'test if server is running or port in use',
84                'debug[=name]' => 'start server under debugger name (gdb, ddd, etc.)',
85                'breakpoint=bp' => 'set breakpoints (multiply bp can be set)',
86                'header' => "add headers to (" .
87                                      join('|', @request_opts) . ") request",
88                'http11' => 'run all tests with HTTP/1.1 (keep alive) requests',
89                'ssl' => 'run tests through ssl',
90                'proxy' => 'proxy requests (default proxy is localhost)',
91                'trace=T' => 'change tracing default to: warning, notice, ' .
92                                     'info, debug, ...',
93                'save' => 'save test paramaters into Apache::TestConfigData',
94                'one-process' => 'run the server in single process mode',
95                (map { $_, "\U$_\E url" } @request_opts),
96             );
97              
98             sub fixup {
99             #make sure we use an absolute path to perl
100             #else Test::Harness uses the perl in our PATH
101             #which might not be the one we want
102 0 0   0 0       $^X = $Config{perlpath} unless -e $^X;
103             }
104              
105             # if the test suite was aborted because of a user-error we don't want
106             # to call the bugreport and invite users to submit a bug report -
107             # after all it's a user error. but we still want the program to fail,
108             # so raise this flag in such a case.
109             my $user_error = 0;
110             sub user_error {
111 0     0 0       my $self = shift;
112 0 0             $user_error = shift if @_;
113 0               $user_error;
114             }
115              
116             sub new {
117 0     0 0       my $class = shift;
118              
119 0               my $self = bless {
120                     tests => [],
121                     @_,
122                 }, $class;
123              
124 0               $self->fixup;
125              
126 0               $self;
127             }
128              
129             #split arguments into test files/dirs and options
130             #take extra care if -e, the file matches /\.t$/
131             # if -d, the dir contains .t files
132             #so we dont slurp arguments that are not tests, example:
133             # httpd $HOME/apache-2.0/bin/httpd
134              
135             sub split_test_args {
136 0     0 0       my($self) = @_;
137              
138 0               my(@tests);
139 0               my $top_dir = $self->{test_config}->{vars}->{top_dir};
140 0               my $t_dir = $self->{test_config}->{vars}->{t_dir};
141              
142 0               my $argv = $self->{argv};
143 0               my @leftovers = ();
144 0               for (@$argv) {
145 0                   my $arg = $_;
146             # need the t/ (or t\) for stat-ing, but don't want to include
147             # it in test output
148 0                   $arg =~ s@^(?:\.[\\/])?t[\\/]@@;
149 0                   my $file = catfile $t_dir, $arg;
150 0 0 0               if (-d $file and $_ ne '/') {
151 0                       my @files = <$file/*.t>;
152 0                       my $remove = catfile $top_dir, "";
153 0 0                     if (@files) {
154 0                           push @tests, map { s,^\Q$remove,,; $_ } @files;
  0            
  0            
155 0                           next;
156                         }
157                     }
158                     else {
159 0 0 0                   if ($file =~ /\.t$/ and -e $file) {
    0          
    0          
160 0                           push @tests, "t/$arg";
161 0                           next;
162                         }
163                         elsif (-e "$file.t") {
164 0                           push @tests, "t/$arg.t";
165 0                           next;
166                         }
167                         elsif (/^[\d.]+$/) {
168 0                           my @t = $_;
169             #support range of subtests: t/TEST t/foo/bar 60..65
170 0 0                         if (/^(\d+)\.\.(\d+)$/) {
171 0                               @t = $1..$2;
172                             }
173              
174 0                           push @{ $self->{subtests} }, @t;
  0            
175 0                           next;
176                         }
177                     }
178 0                   push @leftovers, $_;
179                 }
180              
181 0               $self->{tests} = [ map { canonpath($_) } @tests ];
  0            
182 0               $self->{argv} = \@leftovers;
183             }
184              
185             sub die_on_invalid_args {
186 0     0 0       my($self) = @_;
187              
188             # at this stage $self->{argv} should be empty
189 0               my @invalid_argv = @{ $self->{argv} };
  0            
190 0 0             if (@invalid_argv) {
191 0                   error "unknown opts or test names: @invalid_argv\n" .
192                         "-help will list options\n";
193 0                   exit_perl 0;
194                 }
195              
196             }
197              
198             sub passenv {
199 0     0 0       my $passenv = Apache::TestConfig->passenv;
200 0               for (keys %$passenv) {
201 0 0                 return 1 if $ENV{$_};
202                 }
203 0               0;
204             }
205              
206             sub getopts {
207 0     0 0       my($self, $argv) = @_;
208              
209 0               local *ARGV = $argv;
210 0               my(%opts, %vopts, %conf_opts);
211              
212             # a workaround to support -verbose and -verbose=0|1
213             # $Getopt::Long::VERSION > 2.26 can use the "verbose:1" rule
214             # but we have to support older versions as well
215 0 0             @ARGV = grep defined,
    0          
216 0                   map {/-verbose=(\d)/ ? ($1 ? '-verbose' : undef) : $_ } @ARGV;
217              
218             # permute : optional values can come before the options
219             # pass_through : all unknown things are to be left in @ARGV
220 0               Getopt::Long::Configure(qw(pass_through permute));
221              
222             # grab from @ARGV only the options that we expect
223 0   0           GetOptions(\%opts, @flag_opts, @help_opts,
224                            (map "$_:s", @debug_opts, @request_opts, @ostring_opts),
225                            (map "$_=s", @string_opts),
226                            (map "$_=i", @num_opts),
227 0   0                      (map { ("$_=s", $vopts{$_} ||= []) } @list_opts),
228 0                          (map { ("$_=s", $vopts{$_} ||= {}) } @hash_opts));
229              
230 0               $opts{$_} = $vopts{$_} for keys %vopts;
  0            
231              
232             # separate configuration options and test files/dirs
233 0               my $req_wanted_args = Apache::TestRequest::wanted_args();
234 0               my @argv = ();
235 0               my %req_args = ();
236              
237 0               while (@ARGV) {
238 0                   my $val = shift @ARGV;
239 0 0                 if ($val =~ /^--?(.+)/) { # must have a leading - or --
240 0                       my $key = lc $1;
241             # a known config option?
242 0 0                     if (exists $Apache::TestConfig::Usage{$key}) {
    0          
243 0                           $conf_opts{$key} = shift @ARGV;
244 0                           next;
245                         } # a TestRequest config option?
246                         elsif (exists $req_wanted_args->{$key}) {
247 0                           $req_args{$key} = shift @ARGV;
248 0                           next;
249                         }
250                     }
251             # to be processed later
252 0                   push @argv, $val;
253                 }
254              
255             # save the orig args (make a deep copy)
256 0               $orig_conf_opts = { %conf_opts };
257              
258             # fixup the filepath options on win32 (spaces, short names, etc.)
259 0               if (Apache::TestConfig::WIN32) {
260                     for my $key (keys %conf_opts) {
261                         next unless Apache::TestConfig::conf_opt_is_a_filepath($key);
262                         next unless -e $conf_opts{$key};
263                         $conf_opts{$key} = Win32::GetShortPathName($conf_opts{$key});
264                     }
265                 }
266              
267 0               $opts{req_args} = \%req_args;
268              
269             # only test files/dirs if any at all are left in argv
270 0               $self->{argv} = \@argv;
271              
272             # force regeneration of httpd.conf if commandline args want to
273             # modify it. configure_opts() has more checks to decide whether to
274             # reconfigure or not.
275             # XXX: $self->passenv() is already tested in need_reconfiguration()
276 0               $self->{reconfigure} = $opts{configure} ||
277 0                 (grep { $opts{$_}->[0] } qw(preamble postamble)) ||
278 0   0               (grep { $Apache::TestConfig::Usage{$_} } keys %conf_opts ) ||
      0        
      0        
      0        
279                       $self->passenv() || (! -e 't/conf/httpd.conf');
280              
281 0 0             if (exists $opts{debug}) {
282 0                   $opts{debugger} = $opts{debug};
283 0                   $opts{debug} = 1;
284                 }
285              
286 0 0             if ($opts{trace}) {
287 0                   my %levels = map {$_ => 1} @Apache::TestTrace::Levels;
  0            
288 0 0                 if (exists $levels{ $opts{trace} }) {
289 0                       $Apache::TestTrace::Level = $opts{trace};
290             # propogate the override for the server-side.
291             # -trace overrides any previous APACHE_TEST_TRACE_LEVEL settings
292 0                       $ENV{APACHE_TEST_TRACE_LEVEL} = $opts{trace};
293                     }
294                     else {
295 0                       error "unknown trace level: $opts{trace}",
296                             "valid levels are: @Apache::TestTrace::Levels";
297 0                       exit_perl 0;
298                     }
299              &nb