Revision control
Copy as Markdown
#!/usr/bin/env perl
# Copyright (C) 2017 The Qt Company Ltd.
# SPDX-License-Identifier: LicenseRef-Qt-Commercial OR GPL-3.0-only WITH Qt-GPL-exception-1.0
use 5.010;
use strict;
use warnings;
package QtQA::App::TestPlanner;
=head1 NAME
testplanner - construct a test plan for a set of testcases
=head1 SYNOPSIS
# Make a plan to run all available tests under this directory ...
$ testplanner --input path/to/tests --output testplan.txt
# Then run them all
$ testscheduler --timeout 120 -j4 --sync-output --plan testplan.txt
testplanner will iterate through a build tree, collecting information
about autotests and preparing a test plan to be used by testrunner.
=head2 OPTIONS
=over
=item B<--input> PATH (mandatory)
Specifies the build tree from which a testplan should be created.
=item B<--output> PATH (mandatory)
Specifies the output test plan filename.
=item B<--make> MAKE
Customize the make command to be used for `make check'.
Defaults to `nmake' on Windows and `make' everywhere else.
=back
Further options may be passed to the testcases themselves.
These should be separated from testplanner options with a '--'.
For example:
testplanner --input . --output plan.txt -- -silent -no-crash-handler
... to create a testplan which will run the tests with
"-silent -no-crash-handler" arguments.
=head1 DESCRIPTION
testplanner creates a testplan according to the contents of a given
build tree.
testplanner is primarily designed to work with qmake.
Any test which would be run by the `make check' command under the
build tree will be included in the test plan. This is normally
achieved by using CONFIG+=testcase in a testcase .pro file.
Custom `check' targets may also be used, but these B<must> support
the $(TESTRUNNER) parameter to `make check' as CONFIG+=testcase does.
The precise output format of testplanner is undefined, but it
is plaintext and may be influenced by values from the buildsystem
such as:
=over
=item CONFIG+=insignificant_test
Indicates the result of the test can be ignored.
=item CONFIG+=parallel_test
Indicates the test is safe to run in parallel with other tests.
=item testcase.timeout=I<timeout>
The maximum permitted runtime of the test, in seconds.
=back
=cut
use Data::Dumper;
use English qw(-no_match_vars);
use Fcntl qw(LOCK_EX LOCK_UN SEEK_END);
use File::Basename;
use File::Spec::Functions qw(:ALL);
use File::chdir;
use Getopt::Long;
use IO::File;
use Lingua::EN::Inflect qw(inflect);
use List::MoreUtils qw(any apply all pairwise each_arrayref);
use Pod::Usage;
use QMake::Project;
use Readonly;
use Scalar::Defer qw(force);
use FindBin;
use lib "$FindBin::Bin/../lib/perl5";
use autodie;
Readonly my $WINDOWS => ($OSNAME =~ m{win32}i);
sub new
{
my ($class) = @_;
return bless {
this_script => rel2abs( $0 ),
}, $class;
}
sub run
{
my ($self, @args) = @_;
my $testcase;
local @ARGV = @args;
GetOptions(
'help|?' => sub { pod2usage(0) },
'input=s' => \$self->{ input },
'output=s' => \$self->{ output },
'make=s' => \$self->{ make },
'makefile=s' => \$self->{ makefile },
'testcase' => \$testcase,
) || pod2usage(2);
# Testcase mode; we're calling ourselves for one specific testcase.
# The remaining args are the testcase command and arguments.
if ($testcase) {
return $self->plan_testcase( @ARGV );
}
foreach my $arg (qw(input output)) {
$self->{ $arg } || die "Missing mandatory --$arg argument";
}
# We can't safely handle arguments with spaces.
# The processing of TESTARGS within the makefile depends on the exact
# shell being used, which is generally quite difficult to determine
# (e.g. mingw32-make uses sh.exe if it is in PATH, cmd.exe otherwise).
# It's not impossible to support this, but we won't bother until
# it becomes necessary.
if (any { m{ } } @ARGV) {
die 'sorry, it is currently not supported to pass arguments with '
."spaces while generating a test plan.\nYour arguments were:\n"
.(join(' ', map { "[$_]" } @ARGV));
}
# We're going to pass output to subprocesses with a different
# working directory, we'd better make it absolute
$self->{ output } = rel2abs( $self->{ output } );
# And also delete it if it currently exists
if (-e $self->{ output }) {
unlink( $self->{ output } );
}
if (!$self->{ make }) {
$self->{ make } = $self->default_make( );
}
$self->run_make_check( @ARGV );
$self->finalize_test_plan( $self->{ output } );
return;
}
# finalize the test plan;
# this may modify the test plan slightly (e.g. changing some labels to ensure
# there are no duplicate testcase names).
sub finalize_test_plan
{
my ($self, $filename) = @_;
if (! -e $filename) {
warn "No tests found under $self->{ input }\n";
# No tests? make an empty testplan.
open( my $fh, '>', $filename ) || die "open $filename for create: $!";
close( $fh ) || die "close $filename after create: $!";
return;
}
my @tests;
my $count = 0;
my $fh = IO::File->new( $filename, '<' ) || die "open $filename: $!";
while (my $line = <$fh>) {
++$count;
my $test = eval $line; ## no critic (ProhibitStringyEval) - no way around it
if (my $error = $@) {
die "$filename:$count: error: $error";
}
push @tests, $test;
}
if ($self->ensure_distinct_labels( \@tests )) {
# modified - have to write it back out again.
open( my $fh, '>', $filename ) || die "open $filename for truncate: $!";
close( $fh ) || die "close $filename after truncate: $!";
$self->write_testcase( @tests );
}
print inflect "Test plan generated for NO(test,$count) at $filename\n";
return;
}
# Ensures that all tests referred to by $all_tests_ref (arrayref) have a unique
# label. Returns 1 if the labels had to be modified in order to achieve this.
#
# Currently the labels may be modified by finding the first unique word in a
# test's CWD and command combined. For example, for these two tests:
#
# /build/qtdeclarative/tests/auto/tst_examples/tst_examples
# /build/qtquick1/tests/auto/tst_examples/tst_examples
#
# Their default label would be "tst_examples"; this function would amend them
# to "tst_examples (qtdeclarative)" and "tst_examples (qtquick1)".
#
sub ensure_distinct_labels
{
my ($self, $all_tests_ref) = @_;
my $modified = 0;
# Build a map from each label to a list of tests with that label
my %tests_by_label;
foreach my $test (@{ $all_tests_ref }) {
my $label = $test->{ label };
push @{ $tests_by_label{ $label } }, $test;
}
while (my ($label, $tests_ref) = each %tests_by_label) {
my @tests = @{ $tests_ref };
next unless @tests > 1; # nothing to be done if already unique ...
# found something not unique, we'll have to modify it.
$modified = 1;
# For each test, make a string containing that test's CWD and command/args.
# There must be some difference in this value between the tests (otherwise
# it is the same test!)
#
# Example:
# "/build/qtdeclarative/tests/auto/tst_examples ./tst_examples"
# "/build/qtquick1/tests/auto/tst_examples ./tst_examples"
#
my @cwd_and_args = map { join(' ', $_->{ cwd }, @{ $_->{ args }}) } @tests;
# Find the first unique word from each CWD-and-args string.
#
# Example:
# ("qtdeclarative", "qtquick1")
#
my @words = $self->find_first_unique_word( @cwd_and_args );
# append the unique words to the label.
pairwise {
# this line avoids "used only once: possible typo" warnings
our ($a, $b);
if ($b) {
$a->{ label } .= " ($b)"
}
} @tests, @words;
}
return $modified;
}
# Given a list of @input strings, returns a list (of the same size) of output words.
# Each word is the first unique word from each string (where "word" is defined in
# the perl regular expression sense).
sub find_first_unique_word
{
my ($self, @input) = @_;
# Split on word boundaries, and also consume the non-word characters (e.g.
# directory separators).
# Conceptually, this gives us a two-dimensional array where the rows are input
# strings and columns are individual words in that string.
my @input_words = map { [
split( /\W*\b\W*/, $_ )
] } @input;
# Prepare output, initialized as a list of empty strings, already at the right size.
my @output = (q{}) x (scalar(@input));
# Iterate over each column in the array ...
my $ea = each_arrayref @input_words;
while (my @words = $ea->()) {
# for each output not yet set ...
for (my $i = 0; $i < @output; ++$i) {
next if ($output[$i]);
# if the word at this column is unique, set it as output.
my $word = $words[$i];
next unless $word;
my $count = scalar( grep { $_ eq $word } @words );
if ($count == 1) {
$output[$i] = $word;
}
}
# terminate if all output has been set.
last if all { $_ } @output;
}
return @output;
}
sub default_make
{
my ($self) = @_;
if ($WINDOWS) {
return 'nmake';
}
return 'make';
}
# Returns 'GNU', 'MS' or 'unknown' depending on the type of make
sub make_flavor
{
my ($self) = @_;
my $make = $self->{ make };
if ($make =~ m{\bjom|\bnmake}i) {
return 'MS';
}
if ($make =~ m{\bgmake|\bmake|\bmingw32-make}) {
return 'GNU';
}
return 'unknown';
}
# Returns text usable within make to evaluate the current makefile.
sub makefile_var
{
my ($self) = @_;
if ($self->make_flavor( ) eq 'MS') {
# FIXME: how to accurately figure out the calling Makefile on Windows?
# We know $(MAKEDIR) points to the right directory, but the actual
# filename appears not exposed in any way.
#
# Since there's no way to accurately determine it, we instead glob for
# all "Makefile*", and decide ourselves which one is the right one
# (e.g. discounting Makefile.Release and Makefile.Debug).
#
# Note that for nmake specifically, and not jom, it is necessary to
# double-escape the variable ($$), otherwise it is evaluated too early.
# It's not entirely clear why this is necessary for nmake and not for
# other tools; the method which nmake uses to pass "TESTRUNNER" etc
# args to submakes appears to be undocumented.
my $out = '$(MAKEDIR)\Makefile*';
if ($self->{ make } =~ m{\bnmake}i) {
$out = '$'.$out;
}
return $out;
}
# $(CURDIR): initial working directory of make.
# $(firstword $(MAKEFILE_LIST)): first processed Makefile.
return '$(CURDIR)/$(firstword $(MAKEFILE_LIST))';
}
sub resolved_makefile
{
my ($self) = @_;
my $makefile = $self->{ makefile } || 'Makefile';
# no globbing necessary on makefile flavors other than MS.
if ($self->make_flavor() ne 'MS') {
return $makefile;
}
my @globbed = glob $makefile;
# Omit .Debug and .Release makefiles. There should be a top-level makefile.
@globbed = grep { $_ !~ m{\. (?:Debug|Release) \z}xms } @globbed;
if (!@globbed) {
die "In $CWD, no makefile found (looking for: $makefile)\n";
}
# If we found only one makefile, great! That's the one.
# This is the expected case, the vast majority of the time.
if (@globbed == 1) {
return $globbed[0];
}
# Otherwise, call out to our helper script which can figure out the calling
# makefile from the process table.
my $calling_makefile = qx("$EXECUTABLE_NAME" "$FindBin::Bin/print_calling_makefile.pl");
my $status = $?;
chomp $calling_makefile;
# Worst case scenario - we can't figure out the makefile at all.
# Give up.
if (!$calling_makefile || $status) {
die "Error: ambiguous makefiles:\n"
.join( q{}, map { " $_\n" } @globbed );
}
# $calling_makefile would most likely be a relative path, make it absolute.
# It is resolved relative to whatever directory was used in the glob pattern.
if (!file_name_is_absolute( $calling_makefile )) {
$calling_makefile = rel2abs( $calling_makefile, dirname( $makefile ) );
}
return $calling_makefile;
}
sub plan_testcase
{
my ($self, $testcase, @args) = @_;
my $make = $self->{ make };
my $makefile = $self->resolved_makefile( );
my $prj = QMake::Project->new( $makefile );
# Due to QTCREATORBUG-7170, we cannot let QMake::Project use jom
$prj->set_make( ($make =~ m{\bjom}i) ? 'nmake' : $make );
# Collect all interesting info about the tests.
my @qmake_tests = qw(
parallel_test
insignificant_test
);
my @qmake_scalar_values = qw(
TARGET
testcase.timeout
);
my @qmake_keys = (@qmake_tests, @qmake_scalar_values);
my %info = (
args => [ $testcase, @args ],
cwd => $CWD,
map( { my $v = $prj->test( $_ ); $_ => $v } @qmake_tests),
map( { my $v = $prj->values( $_ ); $_ => $v } @qmake_scalar_values),
);
# flatten info before passing to Data::Dumper
@info{ @qmake_keys } = apply { $_ = force $_ } @info{ @qmake_keys };
# Eliminate any undefined values
if (my @undefined = grep { !defined( $info{ $_ }) } @qmake_keys) {
delete @info{ @undefined };
}
# add a nice "label", which is the primary human-readable name for the
# test in test reports.
$info{ label } = basename( $info{ TARGET } );
# Now write the info to the testplan.
$self->write_testcase( \%info );
print " testplan: $info{ label }\n";
return;
}
# Write all of the given testcase @info (array of hashrefs) to the output file.
sub write_testcase
{
my ($self, @info) = @_;
my $output = $self->{ output };
my @info_strings = map { $self->testcase_to_string( $_ ) } @info;
my $text = join( "\n", @info_strings )."\n";
# Now write the info to the testplan (single line).
open( my $fh, '>>', $output );
flock( $fh, LOCK_EX );
seek( $fh, 0, SEEK_END );
print $fh $text;
flock( $fh, LOCK_UN );
close( $fh );
return;
}
# Given a testcase $info hashref, returns a serialized string representing
# the info. Guaranteed not to contain any newlines.
sub testcase_to_string
{
my ($self, $info) = @_;
my $dumper = Data::Dumper->new( [ $info ] );
$dumper->Indent( 0 ); # all output on one line
$dumper->Terse( 1 ); # omit leading $VAR1
$dumper->Sortkeys( 1 ); # get a predictable order
$dumper->Useqq( 1 ); # handle special characters safely (although none are expected)
my $info_string = $dumper->Dump( );
# trivial sanity check: should be just one line
if ($info_string =~ m{\n}) {
die "internal error: multiple lines in testcase info string:\n$info_string";
}
return $info_string;
}
sub run_make_check
{
my ($self, @args) = @_;
local $CWD = $self->{ input };
# We are going to pass TESTRUNNER and TESTARGS to `make check'.
# If these are already set in the environment, they may interfere with
# our own values, so remove them.
# In practice, this occurs when `nmake check' is used to run the selftests in
# the qtqa repository.
my %clean_env = %ENV;
delete @clean_env{qw(TESTARGS TESTRUNNER)};
local %ENV = %clean_env;
my $make = $self->{ make };
my $output = $self->{ output };
my $this_script = $self->{ this_script };
my @command = ( $make );
my $make_flavor = $self->make_flavor( );
if ($make_flavor eq 'GNU') {
push @command, '-s', '-j4';
} elsif ($make_flavor eq 'MS') {
push @command, '/NOLOGO', '/S';
if ($make =~ m{\bjom}i) {
push @command, '-j4';
}
} else {
warn "Unknown make command $make. May be slow and noisy.\n";
}
my $makefile_var = $self->makefile_var( );
my $subcmd = "$EXECUTABLE_NAME $this_script --make $make --makefile $makefile_var --output $output --testcase";
push @command, (
'check',
"TESTRUNNER=$subcmd --",
"TESTARGS=".join(' ', @args), # note: we know there are no spaces in any of @args
);
if (my $status = system( @command )) {
die "testplan generation failed; @command exited with status $status (exit code ".($status >> 8).')';
}
return;
}
#==================================================================================================
QtQA::App::TestPlanner->new( )->run( @ARGV ) if (!caller);
1;