my
@num_opts
=
qw(times)
;
my
@string_opts
=
qw(order report)
;
my
@flag_opts
=
qw(help verbose bug_mode)
;
my
%order
=
map
{
$_
=> 1}
qw(random repeat)
;
my
%usage
= (
'times=N'
=>
'how many times to run the entire test suite'
.
' (default: '
. DEFAULT_TIMES .
')'
,
'order=MODE'
=>
'modes: random, repeat'
.
' (default: random)'
,
'report=FILENAME'
=>
'save report in a filename'
.
' (default: smoke-report-<date>.txt)'
,
'verbose[=1]'
=>
'verbose output'
.
' (default: 0)'
,
'bug_mode'
=>
'bug report mode'
.
' (default: 0)'
,
);
sub
new {
my
(
$class
,
@argv
) =
@_
;
my
$self
=
bless
{
seen
=> {},
results
=> {},
smoking_completed
=> 0,
tests
=> [],
total_iterations
=> 0,
total_reduction_attempts
=> 0,
total_reduction_successes
=> 0,
total_tests_run
=> 0,
},
ref
(
$class
)||
$class
;
$self
->{test_config} = Apache::TestConfig->thaw;
$self
->getopts(\
@argv
);
my
$opts
=
$self
->{opts};
chdir
"$FindBin::Bin/.."
;
$self
->{
times
} =
$opts
->{
times
} || DEFAULT_TIMES;
$self
->{order} =
$opts
->{order} ||
'random'
;
$self
->{verbose} =
$opts
->{verbose} || 0;
$self
->{run_iter} =
$self
->{
times
};
if
(
$opts
->{bug_mode}) {
$self
->{bug_mode} = 1;
$self
->{run_iter} = 1;
$self
->{
times
} = 1;
$self
->{verbose} = 1;
$self
->{order} =
'random'
;
$self
->{trace} =
'debug'
;
}
$self
->Apache::TestRun::split_test_args();
my
$test_opts
= {
verbose
=>
$self
->{verbose},
tests
=>
$self
->{tests},
order
=>
$self
->{order},
subtests
=>
$self
->{subtests} || [],
};
@{
$self
->{tests} } =
$self
->get_tests(
$test_opts
);
$self
->{base_command} =
"$^X $FindBin::Bin/TEST"
;
$self
->{base_command} .=
" -verbose"
if
$self
->{verbose};
$self
->{start_command} =
"$self->{base_command} -start"
;
$self
->{start_command} .=
" -trace="
.
$self
->{trace}
if
$self
->{trace};
$self
->{run_command} =
"$self->{base_command} -run"
;
$self
->{stop_command} =
"$self->{base_command} -stop"
;
$self
;
}
sub
getopts {
my
(
$self
,
$argv
) =
@_
;
my
%opts
;
local
*ARGV
=
$argv
;
Getopt::Long::Configure(
qw(pass_through permute)
);
GetOptions(\
%opts
,
@flag_opts
,
(
map
"$_=s"
,
@string_opts
),
(
map
"$_=i"
,
@num_opts
));
if
(
exists
$opts
{order} && !
exists
$order
{
$opts
{order}}) {
error
"unknown -order mode: $opts{order}"
;
$self
->opt_help();
exit
;
}
if
(
$opts
{help}) {
$self
->opt_help;
exit
;
}
$self
->{opts} = \
%opts
;
$self
->{argv} = [
@ARGV
];
}
sub
skip { Apache::TestHarness::skip(
@_
); }
sub
prune { Apache::TestHarness::prune(
@_
); }
sub
get_tests { Apache::TestHarness::get_tests(
@_
);}
sub
install_sighandlers {
my
$self
=
shift
;
$SIG
{INT} =
sub
{
$self
->kill_proc();
$self
->report_finish;
exit
;
};
}
END {
local
$?;
eval
{
Apache::TestRun->new(
test_config
=>
Apache::TestConfig->thaw)->scan_core;
};
}
sub
run {
my
(
$self
) =
shift
;
$self
->Apache::TestRun::warn_core();
local
$SIG
{INT};
$self
->install_sighandlers;
$self
->report_start();
if
(
$self
->{bug_mode}) {
$self
->run_bug_mode();
}
else
{
my
$iter
= 0;
while
(
$iter
++ <
$self
->{run_iter}) {
my
$last
=
$self
->run_iter(
$iter
);
last
if
$last
;
}
}
$self
->{smoking_completed} = 1;
$self
->report_finish();
exit
;
}
sub
sep {
my
(
$char
,
$title
) =
@_
;
my
$width
= 60;
if
(
$title
) {
my
$side
=
int
( (
$width
-
length
(
$title
) - 2) / 2);
my
$pad
= (
$side
+1) * 2 +
length
(
$title
) <
$width
? 1 : 0;
return
$char
x
$side
.
" $title "
.
$char
x (
$side
+
$pad
);
}
else
{
return
$char
x
$width
;
}
}
my
%log_files
= ();
sub
logs_init {
my
(
$self
,
@log_files
) =
@_
;
for
my
$path
(
@log_files
) {
my
$fh
= Symbol::gensym();
open
$fh
,
"<$path"
or
die
"Can't open $path: $!"
;
seek
$fh
, 0, POSIX::SEEK_END();
$log_files
{
$path
}[FH] =
$fh
;
$log_files
{
$path
}[POS] =
tell
$fh
;
}
}
sub
logs_end {
for
my
$path
(
keys
%log_files
) {
close
$log_files
{
$path
}[FH];
}
}
sub
log_diff {
my
(
$self
,
$path
) =
@_
;
my
$log
=
$log_files
{
$path
};
die
"no such log file: $path"
unless
$log
;
my
$fh
=
$log
->[FH];
unless
(
defined
$log
->[POS]) {
seek
$fh
, 0, POSIX::SEEK_END();
$log
->[POS] =
tell
$fh
;
return
''
;
}
seek
$fh
,
$log
->[POS], POSIX::SEEK_SET();
local
$/;
my
$diff
= <
$fh
>;
seek
$fh
, 0, POSIX::SEEK_END();
$log
->[POS] =
tell
$fh
;
return
$diff
||
''
;
}
sub
run_bug_mode {
my
(
$self
) =
@_
;
my
$iter
= 0;
warning
"running t/TEST in the bug report mode"
;
my
$reduce_iter
= 0;
my
@good
= ();
my
@tests
= @{
$self
->{tests} };
my
$bad
=
$self
->run_test(
$iter
,
$reduce_iter
, \
@tests
, \
@good
);
$self
->{total_iterations}++;
}
sub
run_iter {
my
(
$self
,
$iter
) =
@_
;
my
$stop_now
= 0;
my
$reduce_iter
= 0;
my
@good
= ();
warning
"\n"
. sep(
"-"
);
warning
sprintf
"[%03d-%02d-%02d] running all tests"
,
$iter
,
$reduce_iter
,
$self
->{
times
};
my
@tests
= @{
$self
->{tests} };
Apache::TestSort->run(\
@tests
,
$self
);
my
$bad
=
$self
->run_test(
$iter
,
$reduce_iter
, \
@tests
, \
@good
);
unless
(
$bad
) {
$self
->{total_iterations}++;
return
$stop_now
;
}
error
"recorded a positive failure ('$bad'), "
.
"will try to minimize the input now"
;
my
$command
=
$self
->{base_command};
{
$reduce_iter
++;
warning
sprintf
"[%03d-%02d-%02d] trying '$bad' on its own"
,
$iter
,
$reduce_iter
, 1;
my
@good
= ();
my
@tests
= (
$bad
);
my
$bad
=
$self
->run_test(
$iter
,
$reduce_iter
, \
@tests
, \
@good
);
if
(
$bad
) {
$stop_now
= 1;
$self
->{total_iterations}++;
unless
(
$self
->sequence_seen(
$self
->{results}, [
@good
,
$bad
])) {
$self
->report_success(
$iter
,
$reduce_iter
,
"$command $bad"
, 1);
}
return
$stop_now
;
}
}
my
$ok_tests
=
@good
;
my
$reduction_success
= 0;
my
$done
= 0;
while
(
@good
> 1) {
my
$tries
= 0;
my
$reduce_sub
=
$self
->reduce_stream(\
@good
);
$reduce_iter
++;
while
(
$tries
++ < MAX_REDUCTION_TRIES) {
$self
->{total_reduction_attempts}++;
my
@try
= @{
$reduce_sub
->() };
unless
(
@try
) {
$done
= 1;
last
;
}
warning
sprintf
"\n[%03d-%02d-%02d] trying %d tests"
,
$iter
,
$reduce_iter
,
$tries
,
scalar
(
@try
);
my
@ok
= ();
my
@tests
= (
@try
,
$bad
);
my
$new_bad
=
$self
->run_test(
$iter
,
$reduce_iter
, \
@tests
, \
@ok
);
if
(
$new_bad
) {
$reduction_success
++;
@good
=
@ok
;
$tries
= 0;
my
$num
=
@ok
;
error
"*** reduction $reduce_iter succeeded ($num tests) ***"
;
$self
->{total_reduction_successes}++;
$self
->log_successful_reduction(
$iter
, \
@ok
);
last
;
}
}
if
(
$done
||
$tries
>= MAX_REDUCTION_TRIES){
error
"no further reductions were made"
;
$done
= 1;
last
;
}
}
unless
(
$self
->sequence_seen(
$self
->{results}, [
@good
,
$bad
])) {
$reduce_iter
= 0
unless
$reduction_success
;
$self
->report_success(
$iter
,
$reduce_iter
,
"$command @good $bad"
,
@good
+ 1);
}
$self
->{total_iterations}++;
return
$stop_now
;
}
sub
reduce_stream {
my
(
$self
) =
shift
;
my
@items
= @{+
shift
};
my
$items
=
@items
;
my
$odd
=
$items
% 2 ? 1 : 0;
my
$middle
=
int
(
$items
/2) - 1;
my
$c
= 0;
return
sub
{
$c
++;
return
\
@items
if
$items
== 1;
my
@try
= ();
my
$max_repeat_tries
= 50;
my
$repeat
= 0;
while
(
$repeat
++ <=
$max_repeat_tries
) {
if
(
$c
== 1) {
@try
=
@items
[(
$middle
+1)..(
$items
-1)];
}
elsif
(
$c
== 2) {
@try
=
@items
[0..
$middle
];
}
else
{
my
$left
=
int
rand
(
$items
);
$left
=
$items
- 1
if
$left
==
$items
- 1;
my
$right
=
$left
+
int
rand
(
$items
-
$left
);
$right
=
$items
- 1
if
$right
>=
$items
;
@try
=
@items
[
$left
..
$right
];
}
if
(
$self
->sequence_seen(
$self
->{seen}, \
@try
)) {
@try
= ();
}
else
{
last
;
}
}
return
\
@try
;
}
}
sub
sequence_seen {
my
(
$self
,
$rh_store
,
$ra_tests
) =
@_
;
my
$digest
= Digest::MD5::md5_hex(
join
''
,
@$ra_tests
);
return
$rh_store
->{
$digest
}++ ? 1 : 0
}
sub
run_test {
my
(
$self
,
$iter
,
$count
,
$tests
,
$ra_ok
) =
@_
;
my
$bad
=
''
;
my
$ra_nok
= [];
$SIG
{PIPE} =
sub
{
die
"pipe broke"
};
{
my
$command
=
$self
->{start_command};
my
$log
=
''
;
IPC::Run3::run3(
$command
,
undef
, \
$log
, \
$log
);
my
$started_ok
= (
$log
=~ /started/) ? 1 : 0;
unless
(
$started_ok
) {
error
"failed to start server\n $log"
;
exit
1;
}
}
my
$t_logs
=
$self
->{test_config}->{vars}->{t_logs};
my
@log_files
=
map
{ catfile
$t_logs
,
$_
}
qw(error_log access_log)
;
$self
->logs_init(
@log_files
);
{
my
$command
=
$self
->{run_command};
my
$max_len
= 1;
for
my
$test
(
@$tests
) {
$max_len
=
length
$test
if
length
$test
>
$max_len
;
}
for
my
$test
(
@$tests
) {
(
my
$test_name
=
$test
) =~ s/\.t$//;
my
$fill
=
"."
x (
$max_len
-
length
$test_name
);
$self
->{total_tests_run}++;
my
$test_command
=
"$command $test"
;
my
$log
=
''
;
IPC::Run3::run3(
$test_command
,
undef
, \
$log
, \
$log
);
my
$ok
= (
$log
=~ /All tests successful|NOTESTS/) ? 1 : 0;
my
@core_files_msg
=
$self
->Apache::TestRun::scan_core_incremental(1);
$ok
= 0
if
@core_files_msg
;
if
(
$ok
== 1) {
push
@$ra_ok
,
$test
;
if
(
$self
->{verbose}) {
if
(
$log
=~ m/NOTESTS/) {
print
STDERR
"$test_name${fill}skipped\n"
;
}
else
{
print
STDERR
"$test_name${fill}ok\n"
;
}
}
my
%log_diffs
=
map
{
$_
=>
$self
->log_diff(
$_
) }
@log_files
;
}
elsif
(
$ok
== 0) {
push
@$ra_nok
,
$test
;
$bad
=
$test
;
if
(
$self
->{verbose}) {
print
STDERR
"$test_name${fill}FAILED\n"
;
error sep(
"-"
);
sleep
5;
my
%log_diffs
=
map
{
$_
=>
$self
->log_diff(
$_
) }
@log_files
;
error
"\t\t*** run log ***"
;
$log
=~ s/^/ /mg;
print
STDERR
"$log\n"
;
for
my
$path
(
@log_files
) {
next
unless
length
$log_diffs
{
$path
};
error
"\t\t*** $path ***"
;
$log_diffs
{
$path
} =~ s/^/ /mg;
print
STDERR
"$log_diffs{$path}\n"
;
}
}
if
(
@core_files_msg
) {
unless
(
$self
->{verbose}) {
error
"$test_name caused core"
;
print
STDERR
join
"\n"
,
@core_files_msg
,
"\n"
;
}
}
if
(
$self
->{verbose}) {
error sep(
"-"
);
}
unless
(
$self
->{bug_mode}) {
last
;
}
}
}
}
$self
->logs_end();
$self
->kill_proc();
if
(
$self
->{bug_mode}) {
warning sep(
"-"
);
if
(
@$ra_nok
== 0) {
printf
STDERR
"All tests successful (%d)\n"
,
scalar
@$ra_ok
;
}
else
{
error
sprintf
"error running %d tests out of %d\n"
,
scalar
(
@$ra_nok
),
scalar
@$ra_ok
+
@$ra_nok
;
}
}
else
{
return
$bad
;
}
}
sub
report_start {
my
(
$self
) =
shift
;
my
$time
=
scalar
localtime
;
$self
->{start_time} =
$time
;
$time
=~ s/\s/_/g;
$time
=~ s/:/-/g;
my
$file
=
$self
->{opts}->{report} ||
catfile Apache::Test::vars(
'top_dir'
),
"smoke-report-$time.txt"
;
$self
->{runtime}->{report} =
$file
;
info
"Report file: $file"
;
open
my
$fh
,
">$file"
or
die
"cannot open $file for writing: $!"
;
$self
->{fh} =
$fh
;
my
$sep
= sep(
"-"
);
my
$title
= sep(
'='
,
"Special Tests Sequence Failure Finder Report"
);
print
$fh
<<EOM;
$title
$sep
First iteration used:
$self->{base_command} @{$self->{tests}}
$sep
EOM
}
sub
report_success {
my
(
$self
,
$iter
,
$reduce_iter
,
$sequence
,
$tests
) =
@_
;
my
@report
= (
"iteration $iter ($tests tests):\n"
,
"\t$sequence\n"
,
"(made $reduce_iter successful reductions)\n\n"
);
print
@report
;
if
(
my
$fh
=
$self
->{fh}) {
print
$fh
@report
;
}
}
sub
report_finish {
my
(
$self
) =
@_
;
my
$start_time
=
$self
->{start_time};
my
$end_time
=
scalar
localtime
;
if
(
my
$fh
=
delete
$self
->{fh}) {
my
$failures
=
scalar
keys
%{
$self
->{results} };
my
$sep
= sep(
"-"
);
my
$cfg_as_string
=
$self
->build_config_as_string;
my
$unique_seqs
=
scalar
keys
%{
$self
->{results} };
my
$attempts
=
$self
->{total_reduction_attempts};
my
$successes
=
$self
->{total_reduction_successes};
my
$completion
=
$self
->{smoking_completed}
?
"Completed"
:
"Not Completed (aborted by user)"
;
my
$status
=
"Unknown"
;
if
(
$self
->{total_iterations} > 0) {
if
(
$failures
) {
$status
=
"*** NOT OK ***"
;
}
else
{
$status
=
"+++ OK +++"
;
}
}
my
$title
= sep(
'='
,
"Summary"
);
my
$iter_made
=
sprintf
"Iterations (%s) made : %d"
,
$self
->{order},
$self
->{total_iterations};
print
$fh
<<EOM;
$title
Completion : $completion
Status : $status
Tests run : $self->{total_tests_run}
$iter_made
EOM
if
(
$attempts
> 0 &&
$failures
) {
my
$reduction_stats
=
sprintf
"%d/%d (%d%% success)"
,
$attempts
,
$successes
,
$successes
/
$attempts
* 100;
print
$fh
<<EOM;
Unique sequences found : $unique_seqs
Reduction tries/success : $reduction_stats
EOM
}
print
$fh
<<EOM;
$sep
--- Started at: $start_time ---
--- Ended at: $end_time ---
$sep
The smoke testing was run on the system with the following
parameters:
$cfg_as_string
-- this report was generated by $0
EOM
close
$fh
;
}
}
sub
log_successful_reduction {
my
(
$self
,
$iter
,
$tests
) =
@_
;
my
$file
=
$self
->{runtime}->{report} .
".$iter.temp"
;
debug
"saving in $file"
;
open
my
$fh
,
">$file"
or
die
"cannot open $file for writing: $!"
;
print
$fh
join
" "
,
@$tests
;
close
$fh
;
}
sub
build_config_as_string {
Apache::TestConfig::as_string();
}
sub
kill_proc {
my
(
$self
) =
@_
;
my
$command
=
$self
->{stop_command};
my
$log
=
''
;
IPC::Run3::run3(
$command
,
undef
, \
$log
, \
$log
);
my
$stopped_ok
= (
$log
=~ /
shutdown
/) ? 1 : 0;
unless
(
$stopped_ok
) {
error
"failed to stop server\n $log"
;
}
}
sub
opt_help {
my
$self
=
shift
;
print
<<EOM;
usage: t/SMOKE [options ...] [tests]
where the options are:
EOM
for
(
sort
keys
%usage
){
printf
" -%-16s %s\n"
,
$_
,
$usage
{
$_
};
}
print
<<EOM;
if 'tests' argument is not provided all available tests will be run
EOM
}
sub
generate_script {
my
(
$class
,
$file
) =
@_
;
$file
||= catfile
't'
,
'SMOKE'
;
my
$content
=
join
"\n"
,
"BEGIN { eval { require blib && blib->import; } }"
,
Apache::TestConfig->perlscript_header,
"use $class;"
,
"$class->new(\@ARGV)->run;"
;
Apache::Test::basic_config()->write_perlscript(
$file
,
$content
);
}
1;