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                 }
300              
301             # breakpoint automatically turns the debug mode on
302 0 0             if (@{ $opts{breakpoint} }) {
  0            
303 0   0               $opts{debug} ||= 1;
304                 }
305              
306 0 0             if ($self->{reconfigure}) {
307 0                   $conf_opts{save} = 1;
308 0                   delete $self->{reconfigure};
309                 }
310                 else {
311 0                   $conf_opts{thaw} = 1;
312                 }
313              
314             #propagate some values
315 0               for (qw(verbose)) {
316 0                   $conf_opts{$_} = $opts{$_};
317                 }
318              
319 0               $self->{opts} = \%opts;
320 0               $self->{conf_opts} = \%conf_opts;
321             }
322              
323             sub default_run_opts {
324 0     0 0       my $self = shift;
325 0               my($opts, $tests) = ($self->{opts}, $self->{tests});
326              
327 0 0             unless (grep { exists $opts->{$_} } @std_run, @request_opts) {
  0            
328 0 0 0               if (@$tests && $self->{server}->ping) {
329             # if certain tests are specified and server is running,
330             # dont restart
331 0                       $opts->{'run-tests'} = 1;
332                     }
333                     else {
334             #default is start-server run-tests stop-server
335 0                       $opts->{$_} = 1 for @std_run;
  0            
336                     }
337                 }
338              
339 0   0           $opts->{'run-tests'} ||= @$tests;
340             }
341              
342             my $parent_pid = $$;
343 0     0 0   sub is_parent { $$ == $parent_pid }
344              
345             my $caught_sig_int = 0;
346              
347             sub install_sighandlers {
348 0     0 0       my $self = shift;
349              
350 0               my($server, $opts) = ($self->{server}, $self->{opts});
351              
352                 $SIG{__DIE__} = sub {
353 0 0   0             return unless $_[0] =~ /^Failed/i; #dont catch Test::ok failures
354              
355             # _show_results() calls die() under a few conditions, such as
356             # when no tests are run or when tests fail. make sure the message
357             # is propagated back to the user.
358 0 0 0               print $_[0] if (caller(1))[3]||'' eq 'Test::Harness::_show_results';
359              
360 0 0                 $server->stop(1) if $opts->{'start-httpd'};
361 0                   $server->failed_msg("error running tests");
362 0                   exit_perl 0;
363 0               };
364              
365                 $SIG{INT} = sub {
366 0 0   0             if ($caught_sig_int++) {
367 0                       warning "\ncaught SIGINT";
368 0                       exit_perl 0;
369                     }
370 0                   warning "\nhalting tests";
371 0 0                 $server->stop if $opts->{'start-httpd'};
372 0                   exit_perl 0;
373 0               };
374              
375             #try to make sure we scan for core no matter what happens
376             #must eval "" to "install" this END block, otherwise it will
377             #always run, a subclass might not want that
378 0               eval 'END {
379             return unless is_parent(); # because of fork
380             $self ||=
381             Apache::TestRun->new(test_config => Apache::TestConfig->thaw);
382             {
383             local $?; # preserve the exit status
384             eval {
385             $self->scan_core;
386             };
387             }
388             $self->try_bug_report();
389             }';
390 0 0             die "failed: $@" if $@;
391              
392             }
393              
394             sub try_bug_report {
395 0     0 0       my $self = shift;
396 0 0 0           if ($? && !$self->user_error &&
      0        
      0        
397                     $self->{opts}->{bugreport} && $self->can('bug_report')) {
398 0                   $self->bug_report;
399                 }
400             }
401              
402             #throw away cached config and start fresh
403             sub refresh {
404 0     0 0       my $self = shift;
405 0               $self->opt_clean(1);
406 0   0           $self->{conf_opts}->{save} = delete $self->{conf_opts}->{thaw} || 1;
407 0               $self->{test_config} = $self->new_test_config()->httpd_config;
408 0               $self->{test_config}->{server}->{run} = $self;
409 0               $self->{server} = $self->{test_config}->server;
410             }
411              
412             sub configure_opts {
413 0     0 0       my $self = shift;
414 0               my $save = shift;
415 0               my $refreshed = 0;
416              
417 0               my($test_config, $opts) = ($self->{test_config}, $self->{opts});
418              
419 0 0 0           $test_config->{vars}->{scheme} =
420                   $opts->{ssl} ? 'https' :
421                     $self->{conf_opts}->{scheme} || 'http';
422              
423 0 0             if ($opts->{http11}) {
424 0                   $ENV{APACHE_TEST_HTTP11} = 1;
425                 }
426              
427             # unless we are already reconfiguring, check for .conf.in files changes
428 0 0 0           if (!$$save &&
429                     (my @reasons =
430                      $self->{test_config}->need_reconfiguration($self->{conf_opts}))) {
431 0                   warning "forcing re-configuration:";
432 0                   warning "\t- $_." for @reasons;
  0            
433 0 0                 unless ($refreshed) {
434 0                       $self->refresh;
435 0                       $refreshed = 1;
436 0                       $test_config = $self->{test_config};
437                     }
438                 }
439              
440             # unless we are already reconfiguring, check for -proxy
441 0 0 0           if (!$$save && exists $opts->{proxy}) {
442 0                   my $max = $test_config->{vars}->{maxclients};
443 0   0               $opts->{proxy} ||= 'on';
444              
445             #if config is cached and MaxClients == 1, must reconfigure
446 0 0 0               if (!$$save and $opts->{proxy} eq 'on' and $max == 1) {
      0        
447 0                       $$save = 1;
448 0                       warning "server is reconfigured for proxy";
449 0 0                     unless ($refreshed) {
450 0                           $self->refresh;
451 0                           $refreshed = 1;
452 0                           $test_config = $self->{test_config};
453                         }
454                     }
455              
456 0                   $test_config->{vars}->{proxy} = $opts->{proxy};
457                 }
458                 else {
459 0                   $test_config->{vars}->{proxy} = 'off';
460                 }
461              
462 0 0             return unless $$save;
463              
464 0     0         my $preamble = sub { shift->preamble($opts->{preamble}) };
  0            
465 0     0         my $postamble = sub { shift->postamble($opts->{postamble}) };
  0            
466              
467 0               $test_config->preamble_register($preamble);
468 0               $test_config->postamble_register($postamble);
469             }
470              
471 0     0 1   sub pre_configure { }
472              
473             sub configure {
474 0     0 0       my $self = shift;
475              
476 0 0             if ($self->{opts}->{'no-httpd'}) {
477 0                   warning "skipping httpd configuration";
478 0                   return;
479                 }
480              
481             # create the conf dir as early as possible
482 0               $self->{test_config}->prepare_t_conf();
483              
484 0               my $save = \$self->{conf_opts}->{save};
485 0               $self->configure_opts($save);
486              
487 0               my $config = $self->{test_config};
488 0 0             unless ($$save) {
489 0                   my $addr = \$config->{vars}->{remote_addr};
490 0                   my $remote_addr = $config->our_remote_addr;
491 0 0                 unless ($$addr eq $remote_addr) {
492 0                       warning "local ip address has changed, updating config cache";
493 0                       $$addr = $remote_addr;
494                     }
495             #update minor changes to cached config
496             #without complete regeneration
497             #for example this allows switching between
498             #'t/TEST' and 't/TEST -ssl'
499 0                   $config->sync_vars(qw(scheme proxy remote_addr));
500 0                   return;
501                 }
502              
503 0               my $test_config = $self->{test_config};
504 0               $test_config->sslca_generate;
505 0 0             $test_config->generate_ssl_conf if $self->{opts}->{ssl};
506 0               $test_config->cmodules_configure;
507 0               $test_config->generate_httpd_conf;
508 0               $test_config->save;
509              
510             # custom config save if
511             # 1) requested to save
512             # 2) no saved config yet
513 0 0 0           if ($self->{opts}->{save} or
514                     !Apache::TestConfig::custom_config_exists()) {
515 0                   $test_config->custom_config_save($self->{conf_opts});
516                 }
517             }
518              
519             sub try_exit_opts {
520 0     0 0       my $self = shift;
521 0               my @opts = @_;
522              
523 0               for (@opts) {
524 0 0                 next unless exists $self->{opts}->{$_};
525 0                   my $method = "opt_$_";
526 0                   my $rc = $self->$method();
527 0 0                 exit_perl $rc if $rc;
528                 }
529              
530 0 0             if ($self->{opts}->{'stop-httpd'}) {
531 0                   my $ok = 1;
532 0 0                 if ($self->{server}->ping) {
533 0                       $ok = $self->{server}->stop;
534 0 0                     $ok = $ok < 0 ? 0 : 1; # adjust to 0/1 logic
535                     }
536                     else {
537 0                       warning "server $self->{server}->{name} is not running";
538             # cleanup a stale pid file if found
539 0                       my $pid_file = $self->{test_config}->{vars}->{t_pid_file};
540 0 0                     unlink $pid_file if -e $pid_file;
541                     }
542 0                   exit_perl $ok;
543                 }
544             }
545              
546             sub start {
547 0     0 0       my $self = shift;
548              
549 0               my $opts = $self->{opts};
550 0               my $server = $self->{server};
551              
552             #if t/TEST -d is running make sure we don't try to stop/start the server
553 0               my $file = $server->debugger_file;
554 0 0 0           if (-e $file and $opts->{'start-httpd'}) {
555 0 0                 if ($server->ping) {
556 0                       warning "server is running under the debugger, " .
557                             "defaulting to -run";
558 0                       $opts->{'start-httpd'} = $opts->{'stop-httpd'} = 0;
559                     }
560                     else {
561 0                       warning "removing stale debugger note: $file";
562 0                       unlink $file;
563                     }
564                 }
565              
566 0               $self->adjust_t_perms();
567              
568 0 0             if ($opts->{'start-httpd'}) {
    0          
569 0 0                 exit_perl 0 unless $server->start;
570                 }
571                 elsif ($opts->{'run-tests'}) {
572 0   0               my $is_up = $server->ping
      0        
      0        
573                         || (exists $self->{opts}->{ping}
574                             && $self->{opts}->{ping} eq 'block'
575                             && $server->wait_till_is_up(STARTUP_TIMEOUT));
576 0 0                 unless ($is_up) {
577 0                       error "server is not ready yet, try again.";
578 0                       exit_perl 0;
579                     }
580                 }
581             }
582              
583             sub run_tests {
584 0     0 0       my $self = shift;
585              
586 0   0           my $test_opts = {
587                     verbose => $self->{opts}->{verbose},
588                     tests => $self->{tests},
589                     times => $self->{opts}->{times},
590                     order => $self->{opts}->{order},
591                     subtests => $self->{subtests} || [],
592                 };
593              
594 0 0             if (grep { exists $self->{opts}->{$_} } @request_opts) {
  0            
595 0                   run_request($self->{test_config}, $self->{opts});
596                 }
597                 else {
598 0 0                 Apache::TestHarness->run($test_opts)
599                         if $self->{opts}->{'run-tests'};
600                 }
601             }
602              
603             sub stop {
604 0     0 0       my $self = shift;
605              
606 0               $self->restore_t_perms;
607              
608 0 0             return $self->{server}->stop if $self->{opts}->{'stop-httpd'};
609             }
610              
611             sub new_test_config {
612 0     0 1       my $self = shift;
613              
614 0               Apache::TestConfig->new($self->{conf_opts});
615             }
616              
617             sub set_ulimit_via_sh {
618 0     0 0       return if Apache::TestConfig::WINFU;
619 0 0             return if $ENV{APACHE_TEST_ULIMIT_SET};
620              
621             # only root can allow unlimited core dumps on Solaris (8 && 9?)
622 0               if (Apache::TestConfig::SOLARIS) {
623                     my $user = getpwuid($>) || '';
624                     if ($user ne 'root') {
625                         warning "Skipping 'set unlimited ulimit for coredumps', " .
626                             "since we are running as a non-root user on Solaris";
627                         return;
628                     }
629                 }
630              
631 0               my $binsh = '/bin/sh';
632 0 0             return unless -e $binsh;
633 0               $ENV{APACHE_TEST_ULIMIT_SET} = 1;
634              
635 0               my $sh = Symbol::gensym();
636 0 0             open $sh, "echo ulimit -a | $binsh|" or die;
637 0               local $_;
638 0               while (<$sh>) {
639 0 0                 if (/^core.*unlimited$/) {
640             #already set to unlimited
641 0                       $ENV{APACHE_TEST_ULIMIT_SET} = 1;
642 0                       return;
643                     }
644                 }
645 0               close $sh;
646              
647 0               $orig_command = "ulimit -c unlimited; $orig_command";
648 0               warning "setting ulimit to allow core files\n$orig_command";
649             # use 'or die' to avoid warnings due to possible overrides of die
650 0 0             exec $orig_command or die "exec $orig_command has failed";
651             }
652              
653             sub set_ulimit {
654 0     0 0       my $self = shift;
655             #return if $self->set_ulimit_via_bsd_resource;
656 0               eval { $self->set_ulimit_via_sh };
  0            
657             }
658              
659             sub set_env {
660             #export some environment variables for t/modules/env.t
661             #(the values are unimportant)
662 0     0 0       $ENV{APACHE_TEST_HOSTNAME} = 'test.host.name';
663 0               $ENV{APACHE_TEST_HOSTTYPE} = 'z80';
664             }
665              
666             sub run {
667 0     0 0       my $self = shift;
668              
669             # assuming that test files are always in the same directory as the
670             # driving script, make it possible to run the test suite from any place
671             # use a full path, which will work after chdir (e.g. ./TEST)
672 0               $0 = File::Spec->rel2abs($0);
673 0 0             if (-e $0) {
674 0                   my $top = dirname dirname $0;
675 0 0 0               chdir $top if $top and -d $top;
676                 }
677              
678             # reconstruct argv, preserve multiwords args, eg 'PerlTrace all'
679 0 0             my $argv = join " ", map { /^-/ ? $_ : qq['$_'] } @ARGV;
  0            
680 0               $orig_command = "$^X $0 $argv";
681 0               $orig_cwd = Cwd::cwd();
682 0               $self->set_ulimit;
683 0               $self->set_env; #make sure these are always set
684              
685 0               $self->detect_relocation($orig_cwd);
686              
687 0               my(@argv) = @_;
688              
689 0               $self->getopts(\@argv);
690              
691             # must be called after getopts so the tracing will be set right
692 0               Apache::TestConfig::custom_config_load();
693              
694 0               $self->pre_configure();
695              
696             # can't setup the httpd-specific parts of the config object yet
697 0               $self->{test_config} = $self->new_test_config();
698              
699 0               $self->warn_core();
700              
701             # give TestServer access to our runtime configuration directives
702             # so we can tell the server stuff if we need to
703 0               $self->{test_config}->{server}->{run} = $self;
704              
705 0               $self->{server} = $self->{test_config}->server;
706              
707 0               local($SIG{__DIE__}, $SIG{INT});
708 0               $self->install_sighandlers;
709              
710 0               $self->try_exit_opts(@exit_opts_no_need_httpd);
711              
712             # httpd is found here (unless it was already configured before)
713 0               $self->{test_config}->httpd_config();
714              
715 0               $self->try_exit_opts(@exit_opts_need_httpd);
716              
717 0 0             if ($self->{opts}->{configure}) {
718 0                   warning "cleaning out current configuration";
719 0                   $self->opt_clean(1);
720                 }
721              
722             # if configure() fails for some reason before it has flushed the
723             # config to a file, save it so -clean will be able to clean
724 0 0             unless ($self->{opts}->{clean}) {
725 0                   eval { $self->configure };
  0            
726 0 0                 if ($@) {
727 0                       error "configure() has failed:\n$@";
728 0                       warning "forcing Apache::TestConfig object save";
729 0                       $self->{test_config}->save;
730 0                       warning "run 't/TEST -clean' to clean up before continuing";
731 0                       exit_perl 0;
732                     }
733                 }
734              
735 0 0             if ($self->{opts}->{configure}) {
736 0                   warning "reconfiguration done";
737 0                   exit_perl 1;
738                 }
739              
740 0               $self->default_run_opts;
741              
742 0               $self->split_test_args;
743              
744 0               $self->die_on_invalid_args;
745              
746 0 0             $self->start unless $self->{opts}->{'no-httpd'};
747              
748 0               $self->run_tests;
749              
750 0 0             $self->stop unless $self->{opts}->{'no-httpd'};
751             }
752              
753             sub rerun {
754 0     0 0       my $vars = shift;
755              
756             # in %$vars
757             # - httpd will be always set
758             # - apxs is optional
759              
760 0   0           $orig_cwd ||= Cwd::cwd();
761 0               chdir $orig_cwd;
762 0               my $new_opts = " -httpd $vars->{httpd}";
763 0 0             $new_opts .= " -apxs $vars->{apxs}" if $vars->{apxs};
764              
765 0               my $new_command = $orig_command;
766              
767             # strip any old bogus -httpd/-apxs
768 0 0             $new_command =~ s/--?httpd\s+$orig_conf_opts->{httpd}//
769                     if $orig_conf_opts->{httpd};
770 0 0 0           $new_command =~ s/--?httpd\s+$orig_conf_opts->{httpd}//
771                     if $orig_conf_opts->{httpd} and $vars->{apxs};
772              
773             # add new opts
774 0               $new_command .= $new_opts;
775              
776 0               warning "running with new config opts: $new_command";
777              
778             # use 'or die' to avoid warnings due to possible overrides of die
779 0 0             exec $new_command or die "exec $new_command has failed";
780             }
781              
782              
783             # make it easy to move the whole distro w/o running
784             # 't/TEST -clean' before moving. when moving the whole package,
785             # the old cached config will stay, so we want to nuke it only if
786             # we realize that it's no longer valid. we can't just check the
787             # existance of the saved top_dir value, since the project may have
788             # been copied and the old dir could be still there, but that's not
789             # the one that we work in
790             sub detect_relocation {
791 0     0 0       my($self, $cur_top_dir) = @_;
792              
793 0               my $config_file = catfile qw(t conf apache_test_config.pm);
794 0 0             return unless -e $config_file;
795              
796 0               my %inc = %INC;
797 0               eval { require "$config_file" };
  0            
798 0               %INC = %inc; # be stealth
799 0 0             warn($@), return if $@;
800              
801 0               my $cfg = 'apache_test_config'->new;
802              
803             # if the top_dir from saved config doesn't match the current
804             # top_dir, that means that the whole project was relocated to a
805             # different directory, w/o running t/TEST -clean first (in each
806             # directory with a test suite)
807 0               my $cfg_top_dir = $cfg->{vars}->{top_dir};
808 0 0             return unless $cfg_top_dir;
809 0 0             return if $cfg_top_dir eq $cur_top_dir;
810              
811             # if that's the case silently fixup the saved config to use the
812             # new paths, and force a complete cleanup. if we don't fixup the
813             # config files, the cleanup process won't be able to locate files
814             # to delete and re-configuration will fail
815                 {
816             # in place editing
817 0                   local @ARGV = $config_file;
  0            
818 0                   local $^I = ".bak"; # Win32 needs a backup
819 0                   while (<>) {
820 0                       s{$cfg_top_dir}{$cur_top_dir}g;
821 0                       print;
822                     }
823 0                   unlink $config_file . $^I;
824                 }
825              
826 0               my $cleanup_cmd = "$^X $0 -clean";
827 0               warning "cleaning up the old config";
828             # XXX: do we care to check success?
829 0               system $cleanup_cmd;
830              
831             # XXX: I tried hard to accomplish that w/o starting a new process,
832             # but too many things get on the way, so for now just keep it as an
833             # external process, as it's absolutely transparent to the normal
834             # app-run
835             }
836              
837             my @oh = qw(jeez golly gosh darn shucks dangit rats nuts dangnabit crap);
838             sub oh {
839 0     0 0       $oh[ rand scalar @oh ];
840             }
841              
842             #e.g. t/core or t/core.12499
843             my $core_pat = '^core(\.\d+)?' . "\$";
844              
845             # $self->scan_core_incremental([$only_top_dir])
846             # normally would be called after each test
847             # and since it updates the list of seen core files
848             # scan_core() won't report these again
849             # currently used in Apache::TestSmoke
850             #
851             # if $only_t_dir arg is true only the t_dir dir (t/) will be scanned
852             sub scan_core_incremental {
853 0     0 0       my($self, $only_t_dir) = @_;
854 0               my $vars = $self->{test_config}->{vars};
855              
856             # no core files dropped on win32
857 0               return () if Apache::TestConfig::WIN32;
858              
859 0 0             if ($only_t_dir) {
860 0                   require IO::Dir;
861 0                   my @cores = ();
862 0                   for (IO::Dir->new($vars->{t_dir})->read) {
863 0                       my $file = catfile $vars->{t_dir}, $_;
864 0 0                     next unless -f $file;
865 0 0                     next unless /$core_pat/o;
866 0 0 0                   next if exists $core_files{$file} &&
867                             $core_files{$file} == -M $file;
868 0                       $core_files{$file} = -M $file;
869 0                       push @cores, $file;
870                     }
871                     return @cores
872 0                       ? join "\n", "server dumped core, for stacktrace, run:",
873 0 0                         map { "gdb $vars->{httpd} -core $_" } @cores
874                         : ();
875                 }
876              
877 0               my @msg = ();
878                 finddepth({ no_chdir => 1,
879                             wanted => sub {
880 0 0   0             return unless -f $_;
881 0                   my $file = basename $File::Find::name;
882 0 0                 return unless $file =~ /$core_pat/o;
883 0                   my $core = $File::Find::name;
884 0 0 0               unless (exists $core_files{$core} && $core_files{$core} == -M $core) {
885             # new core file!
886              
887             # XXX: could rename the file if it doesn't include the pid
888             # in its name (i.e., just called 'core', instead of 'core.365')
889              
890             # XXX: could pass the test name and rename the core file
891             # to use that name as a suffix, plus pid, time or some
892             # other unique identifier, in case the same test is run
893             # more than once and each time it caused a segfault
894 0                       $core_files{$core} = -M $core;
895 0                       push @msg, "server dumped core, for stacktrace, run:\n" .
896                             "gdb $vars->{httpd} -core $core";
897                     }
898 0               }}, $vars->{top_dir});
899              
900 0               return @msg;
901              
902             }
903              
904             sub scan_core {
905 0     0 0       my $self = shift;
906 0               my $vars = $self->{test_config}->{vars};
907 0               my $times = 0;
908              
909             # no core files dropped on win32
910 0               return if Apache::TestConfig::WIN32;
911              
912                 finddepth({ no_chdir => 1,
913                             wanted => sub {
914 0 0   0             return unless -f $_;
915 0                   my $file = basename $File::Find::name;
916 0 0                 return unless $file =~ /$core_pat/o;
917 0                   my $core = $File::Find::name;
918 0 0 0               if (exists $core_files{$core} && $core_files{$core} == -M $core) {
919             # we have seen this core file before the start of the test
920 0                       info "an old core file has been found: $core";
921                     }
922                     else {
923 0                       my $oh = oh();
924 0 0                     my $again = $times++ ? "again" : "";
925 0                       error "oh $oh, server dumped core $again";
926 0                       error "for stacktrace, run: gdb $vars->{httpd} -core $core";
927                     }
928 0               }}, $vars->{top_dir});
929             }
930              
931             # warn the user that there is a core file before the tests
932             # start. suggest to delete it before proceeding or a false alarm can
933             # be generated at the end of the test routine run.
934             sub warn_core {
935 0     0 0       my $self = shift;
936 0               my $vars = $self->{test_config}->{vars};
937 0               %core_files = (); # reset global
938              
939             # no core files dropped on win32
940 0               return if Apache::TestConfig::WIN32;
941              
942                 finddepth(sub {
943 0 0   0             return unless -f $_;
944 0 0                 return unless /$core_pat/o;
945 0                   my $core = "$File::Find::dir/$_";
946 0                   info "consider removing an old $core file before running tests";
947             # remember the timestamp of $core so we can check if it's the
948             # old core file at the end of the run and not complain then
949 0                   $core_files{$core} = -M $core;
950 0               }, $vars->{top_dir});
951             }
952              
953             # this function handles the cases when the test suite is run under
954             # 'root':
955             #
956             # 1. When user 'bar' is chosen to run Apache with, files and dirs
957             # created by 'root' might be not writable/readable by 'bar'
958             #
959             # 2. when the source is extracted as user 'foo', and the chosen user
960             # to run Apache under is 'bar', in which case normally 'bar' won't
961             # have the right permissions to write into the fs created by 'foo'.
962             #
963             # We solve that by 'chown -R bar.bar t/' in a portable way.
964             #
965             # 3. If the parent directory is not rwx for the chosen user, that user
966             # won't be able to read/write the DocumentRoot. In which case we
967             # have nothing else to do, but to tell the user to fix the situation.
968             #
969             sub adjust_t_perms {
970 0     0 0       my $self = shift;
971              
972 0               return if Apache::TestConfig::WINFU;
973              
974 0               %original_t_perms = (); # reset global
975              
976 0   0           my $user = getpwuid($>) || '';
977 0 0             if ($user eq 'root') {
978 0                   my $vars = $self->{test_config}->{vars};
979 0                   my $user = $vars->{user};
980 0 0                 my($uid, $gid) = (getpwnam($user))[2..3]
981                         or die "Can't find out uid/gid of '$user'";
982              
983 0                   warning "root mode: ".
984                         "changing the files ownership to '$user' ($uid:$gid)";
985                     finddepth(sub {
986 0     0                 $original_t_perms{$File::Find::name} = [(stat $_)[4..5]];
987 0                       chown $uid, $gid, $_;
988 0                   }, $vars->{t_dir});
989              
990 0                   $self->check_perms($user, $uid, $gid);
991              
992 0                   $self->become_nonroot($user, $uid, $gid);
993                 }
994             }
995              
996             sub restore_t_perms {
997 0     0 0       my $self = shift;
998              
999 0               return if Apache::TestConfig::WINFU;
1000              
1001 0 0             if (%original_t_perms) {
1002 0                   warning "root mode: restoring the original files ownership";
1003 0                   my $vars = $self->{test_config}->{vars};
1004 0                   while (my($file, $ids) = each %original_t_perms) {
1005 0 0                     next unless -e $file; # files could be deleted
1006 0                       chown @$ids, $file;
1007                     }
1008                 }
1009             }
1010              
1011             # this sub is executed from an external process only, since it
1012             # "sudo"'s into a uid/gid of choice
1013             sub run_root_fs_test {
1014 0     0 0       my($uid, $gid, $dir) = @_;
1015              
1016             # first must change gid and egid ("$gid $gid" for an empty
1017             # setgroups() call as explained in perlvar.pod)
1018 0               my $groups = "$gid $gid";
1019 0               $( = $) = $groups;
1020 0 0 0           die "failed to change gid to $gid"
1021                     unless $( eq $groups && $) eq $groups;
1022              
1023             # only now can change uid and euid
1024 0               $< = $> = $uid+0;
1025 0 0 0           die "failed to change uid to $uid" unless $< == $uid && $> == $uid;
1026              
1027 0               my $file = catfile $dir, ".apache-test-file-$$-".time.int(rand);
1028 0               eval "END { unlink q[$file] }";
1029              
1030             # unfortunately we can't run the what seems to be an obvious test:
1031             # -r $dir && -w _ && -x _
1032             # since not all perl implementations do it right (e.g. sometimes
1033             # acls are ignored, at other times setid/gid change is ignored)
1034             # therefore we test by trying to attempt to read/write/execute
1035              
1036             # -w
1037 0 0             open TEST, ">$file" or die "failed to open $file: $!";
1038              
1039             # -x
1040 0 0             -f $file or die "$file cannot be looked up";
1041 0               close TEST;
1042              
1043             # -r
1044 0 0             opendir DIR, $dir or die "failed to open dir $dir: $!";
1045 0 0             defined readdir DIR or die "failed to read dir $dir: $!";
1046 0               close DIR;
1047              
1048             # all tests passed
1049 0               print "OK";
1050             }
1051              
1052             sub check_perms {
1053 0     0 0       my ($self, $user, $uid, $gid) = @_;
1054              
1055             # test that the base dir is rwx by the selected non-root user
1056 0               my $vars = $self->{test_config}->{vars};
1057 0               my $dir = $vars->{t_dir};
1058 0               my $perl = Apache::TestConfig::shell_ready($vars->{perl});
1059              
1060             # find where Apache::TestRun was loaded from, so we load this
1061             # exact package from the external process
1062 0               my $inc = dirname dirname $INC{"Apache/TestRun.pm"};
1063 0               my $sub = "Apache::TestRun::run_root_fs_test";
1064 0               my $check = <<"EOI";
1065             $perl -Mlib=$inc -MApache::TestRun -e 'eval { $sub($uid, $gid, q[$dir]) }';
1066             EOI
1067 0               warning "testing whether '$user' is able to -rwx $dir\n$check\n";
1068              
1069 0   0           my $res = qx[$check] || '';
1070 0               warning "result: $res";
1071 0 0             unless ($res eq 'OK') {
1072 0                   $self->user_error(1);
1073             #$self->restore_t_perms;
1074 0                   error <<"EOI";
1075             You are running the test suite under user 'root'.
1076             Apache cannot spawn child processes as 'root', therefore
1077             we attempt to run the test suite with user '$user' ($uid:$gid).
1078             The problem is that the path (including all parent directories):
1079             $dir
1080             must be 'rwx' by user '$user', so Apache can read and write under that
1081             path.
1082            
1083             There are several ways to resolve this issue. One is to move and
1084             rebuild the distribution to '/tmp/' and repeat the 'make test'
1085             phase. The other is not to run 'make test' as root (i.e. building
1086             under your /home/user directory).
1087            
1088             You can test whether some directory is suitable for 'make test' under
1089             'root', by running a simple test. For example to test a directory
1090             '$dir', run:
1091            
1092             % $check
1093             Only if the test prints 'OK', the directory is suitable to be used for
1094             testing.
1095             EOI
1096 0                   skip_test_suite();
1097 0                   exit_perl 0;
1098                 }
1099             }
1100              
1101             # in case the client side creates any files after the initial chown
1102             # adjustments we want the server side to be able to read/write them, so
1103             # they better be with the same permissions. dropping root permissions
1104             # and becoming the same user as the server side solves this problem.
1105             sub become_nonroot {
1106 0     0 0       my ($self, $user, $uid, $gid) = @_;
1107              
1108 0               warning "the client side drops 'root' permissions and becomes '$user'";
1109              
1110             # first must change gid and egid ("$gid $gid" for an empty
1111             # setgroups() call as explained in perlvar.pod)
1112 0               my $groups = "$gid $gid";
1113 0               $( = $) = $groups;
1114 0 0 0           die "failed to change gid to $gid" unless $( eq $groups && $) eq $groups;
1115              
1116             # only now can change uid and euid
1117 0               $< = $> = $uid+0;
1118 0 0 0           die "failed to change uid to $uid" unless $< == $uid && $> == $uid;
1119             }
1120              
1121             sub run_request {
1122 0     0 0       my($test_config, $opts) = @_;
1123              
1124 0               my @args = (%{ $opts->{header} }, %{ $opts->{req_args} });
  0            
  0            
1125              
1126 0               my($request, $url) = ("", "");
1127              
1128 0               for (@request_opts) {
1129 0 0                 next unless exists $opts->{$_};
1130 0 0                 $url = $opts->{$_} if $opts->{$_};
1131 0 0                 $request = join $request ? '_' : '', $request, $_;
1132                 }
1133              
1134 0 0             if ($request) {
1135 0                   my $method = \&{"Apache::TestRequest::\U$request"};
  0            
1136 0                   my $res = $method->($url, @args);
1137 0                   print Apache::TestRequest::to_string($res);
1138                 }
1139             }
1140              
1141             sub opt_clean {
1142 0     0 0       my($self, $level) = @_;
1143 0               my $test_config = $self->{test_config};
1144 0               $test_config->server->stop;
1145 0               $test_config->clean($level);
1146 0               1;
1147             }
1148              
1149             sub opt_ping {
1150 0     0 0       my($self) = @_;
1151              
1152 0               my $test_config = $self->{test_config};
1153 0               my $server = $test_config->server;
1154 0               my $pid = $server->ping;
1155 0               my $name = $server->{name};
1156             # support t/TEST -ping=block -run ...
1157 0               my $exit = not $self->{opts}->{'run-tests'};
1158              
1159 0 0             if ($pid) {
1160 0 0                 if ($pid == -1) {
1161 0                       error "port $test_config->{vars}->{port} is in use, ".
1162                               "but cannot determine server pid";
1163                     }
1164                     else {
1165 0                       my $version = $server->{version};
1166 0                       warning "server $name running (pid=$pid, version=$version)";
1167                     }
1168 0                   return $exit;
1169                 }
1170              
1171 0 0 0           if (exists $self->{opts}->{ping} && $self->{opts}->{ping} eq 'block') {
1172 0                   $server->wait_till_is_up(STARTUP_TIMEOUT);
1173                 }
1174                 else {
1175 0                   warning "no server is running on $name";
1176                 }
1177              
1178 0               return $exit; #means call exit() if true
1179             }
1180              
1181             sub test_inc {
1182 0     0 0       map { "$_/Apache-Test/lib" } qw(. ..);
  0            
1183             }
1184              
1185             sub set_perl5lib {
1186 0     0 0       $ENV{PERL5LIB} = join $Config{path_sep}, shift->test_inc();
1187             }
1188              
1189             sub set_perldb_opts {
1190 0     0 0       my $config = shift->{test_config};
1191 0               my $file = catfile $config->{vars}->{t_logs}, 'perldb.out';
1192 0               $config->genfile($file); #mark for -clean
1193 0               $ENV{PERLDB_OPTS} = "NonStop frame=4 AutoTrace LineInfo=$file";
1194 0               warning "perldb log is t/logs/perldb.out";
1195             }
1196              
1197             sub opt_debug {
1198 0     0 0       my $self = shift;
1199 0               my $server = $self->{server};
1200              
1201 0               my $opts = $self->{opts};
1202 0               my $debug_opts = {};
1203              
1204 0               for (qw(debugger breakpoint)) {
1205 0                   $debug_opts->{$_} = $opts->{$_};
1206                 }
1207              
1208 0 0             if (my $db = $opts->{debugger}) {
1209 0 0                 if ($db =~ s/^perl=?//) {
    0          
1210 0                       $opts->{'run-tests'} = 1;
1211 0                       $self->start; #if not already running
1212 0                       $self->set_perl5lib;
1213 0 0                     $self->set_perldb_opts if $db eq 'nostop';
1214 0                       system $^X, '-MApache::TestPerlDB', '-d', @{ $self->{tests} };
  0            
1215 0                       $self->stop;
1216 0                       return 1;
1217                     }
1218                     elsif ($db =~ s/^lwp[=:]?//) {
1219 0   0                   $ENV{APACHE_TEST_DEBUG_LWP} = $db || 1;
1220 0                       $opts->{verbose} = 1;
1221 0                       return 0;
1222                     }
1223                 }
1224              
1225 0               $server->stop;
1226 0               $server->start_debugger($debug_opts);
1227 0               1;
1228             }
1229              
1230             sub opt_help {
1231 0     0 0       my $self = shift;
1232              
1233 0               print <<EOM;
1234             usage: TEST [options ...]
1235             where options include:
1236             EOM
1237              
1238 0               for (sort keys %usage){
1239 0                   printf " -%-13s %s\n", $_, $usage{$_};
1240                 }
1241              
1242 0               print "\n configuration options:\n";
1243              
1244 0               Apache::TestConfig->usage;
1245 0               1;
1246             }
1247              
1248             # generate t/TEST script (or a different filename) which will drive
1249             # Apache::TestRun
1250             sub generate_script {
1251 0     0 0       my ($class, @opts) = @_;
1252              
1253 0               my %opts = ();
1254              
1255             # back-compat
1256 0 0             if (@opts == 1) {
1257 0                   $opts{file} = $opts[0];
1258                 }
1259                 else {
1260 0                   %opts = @opts;
1261 0   0               $opts{file} ||= catfile 't', 'TEST';
1262                 }
1263              
1264 0               my $body = "BEGIN { eval { require blib && blib->import; } }\n";
1265              
1266 0               my %args = @Apache::TestMM::Argv;
1267 0               while (my($k, $v) = each %args) {
1268 0                   $v =~ s/\|/\\|/g;
1269 0                   $body .= "\n\$Apache::TestConfig::Argv{'$k'} = q|$v|;\n";
1270                 }
1271              
1272 0               my $header = Apache::TestConfig->perlscript_header;
1273              
1274 0               $body .= join "\n",
1275                     $header, "use $class ();";
1276              
1277 0 0             if (my $report = $opts{bugreport}) {
1278 0                   $body .= "\n\npackage $class;\n" .
1279                              "sub bug_report { print '$report' }\n\n";
1280                 }
1281              
1282 0               $body .= "$class->new->run(\@ARGV);";
1283              
1284 0               Apache::Test::basic_config()->write_perlscript($opts{file},
1285                                                                $body);
1286             }
1287              
1288             # in idiomatic per