Revision control
++ #!/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;
++