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 strict;
++ use warnings;
++
++ package QtQaTest;
++
++ =head1 NAME
++
++ test.pl - run autotests for the Qt QA scripts
++
++ =head1 SYNOPSIS
++
++ ./test.pl [ --clean ]
++
++ Run the automated test suite in this repository.
++
++ =head2 Options:
++
++ =over
++
++ =item --clean
++
++ Instead of running against the perl environment set up
++ in the caller's environment, create a new perl environment
++ in a temporary directory, and delete it after the test completes.
++
++ This is the most accurate way to test that all prerequisites are
++ correctly specified in setup.pl. However, it significantly increases
++ the test time.
++
++ =back
++
++ On a typical clean Linux workstation, this script shouldn't require any
++ additional prerequisites other than the perl B<local::lib> dependency
++ needed by L<setup.pl>.
++
++ =cut
++
++ use English qw( -no_match_vars );
++ use File::Path qw( rmtree );
++ use File::Spec::Functions qw( catfile );
++ use File::Temp qw( tempdir );
++ use FindBin qw( );
++ use Getopt::Long qw( GetOptionsFromArray );
++ use Pod::Usage qw( pod2usage );
++
++ sub new
++ {
++ my ($class, @args) = @_;
++
++ my %self = (
++ 'clean' => 0,
++ );
++
++ GetOptionsFromArray(\@args,
++ "clean" => \$self{ 'clean' },
++ "help" => sub { pod2usage(1) },
++ ) || pod2usage(2);
++
++ bless \%self, $class;
++ return \%self;
++ }
++
++ sub system_or_die
++ {
++ my ($self, @command_with_args) = @_;
++
++ my $command = join(" ", @command_with_args);
++ print "+ $command\n";
++ system(@command_with_args);
++ if ($? == -1) {
++ die "$command failed to execute: $!\n";
++ }
++ elsif ($? & 127) {
++ die(sprintf "$command died with signal %d\n", ($? & 127));
++ }
++ elsif ($?) {
++ die(sprintf "$command exited with value %d\n", $? >> 8);
++ }
++
++ return;
++ }
++
++ # Use setup.pl to install prereqs
++ sub run_setup_pl
++ {
++ my $self = shift;
++
++ my $setup = catfile($FindBin::Bin, 'setup.pl');
++ my @cmd = ('perl', $setup, '--install');
++ if ($self->{perldir}) {
++ push @cmd, '--prefix', $self->{perldir};
++ }
++
++ $self->system_or_die(@cmd);
++
++ return;
++ }
++
++ # Run all of the autotests, using prove.
++ sub run_prove
++ {
++ my $self = shift;
++
++ # While running the tests, it is good to use a
++ # "temporary temporary directory", because a few things expect to use /tmp
++ # as semi-persistent storage. Ideally nothing would do this, but some third
++ # party modules may do so.
++ #
++ # We clean up the directory before the test if it exists, but we make no
++ # attempt to clean up this directory after the test:
++ #
++ # - if running in CI system, the CI system will clean it
++ # - if running locally, and a test fails, the user might like to look at
++ # some of the data left behind
++ #
++ my $tmpdir = catfile($FindBin::Bin, 'test_pl_tmp');
++ if (-e $tmpdir) {
++ rmtree($tmpdir, 0, 0) || die "rmtree $tmpdir: $OS_ERROR";
++ }
++ mkdir($tmpdir) || die "mkdir $tmpdir: $OS_ERROR";
++ local $ENV{TMPDIR} = $tmpdir;
++
++ # options always passed to `prove'
++ my @prove_options = (
++ # Let tests freely use modules under lib/perl5
++ '-I',
++ "$FindBin::Bin/lib/perl5",
++ );
++
++ my @prove = (
++ 'prove',
++
++ @prove_options,
++
++ # Use `--merge' because we have some tests which are expected to output a
++ # lot of stderr which look like errors (e.g. test for the Pulse::x handling
++ # of transient errors). Having these visible by default is rather
++ # confusing to e.g. the CI system, which will extract these "errors" into
++ # report emails.
++ #
++ # If there is a failure, we will re-run the tests later without `--merge',
++ # so failing tests will still have all the details available.
++ '--merge',
++
++ # Use `--state=save' so, if running manually, the user can easily
++ # re-run only the failed tests if desired; and to support the rerun-tests
++ # option.
++ #
++ '--state=save',
++
++ # Let tests freely use modules under lib/perl5
++ '-I',
++ "$FindBin::Bin/lib/perl5",
++
++ # Run all tests under the directory in which test.pl is located
++ '--recurse',
++ $FindBin::Bin
++ );
++
++ eval { $self->system_or_die(@prove) };
++ my $error = $@;
++ if ($error) {
++ print "\n\nI'm going to run only the failed tests again:\n";
++ $self->system_or_die(
++ 'prove',
++
++ @prove_options,
++
++ # This will run only the tests which were marked as failing ...
++ '--state=failed,save',
++
++ # ...and this will be quite verbose, to aid in
++ # figuring out the problem.
++ '--verbose',
++ );
++
++ # The second attempt may have passed, in the case of unstable
++ # tests, but we still should consider this a fatal error.
++ die $error;
++ }
++
++ return;
++ }
++
++ sub make_clean_prefix
++ {
++ my ($self) = @_;
++
++ my $cleandir = tempdir( 'qt-qa-test-pl.XXXXXX', CLEANUP => 1, TMPDIR => 1 );
++
++ print "Using $cleandir as perl prefix.\n";
++
++ # perl: local::lib creates the dirs and sets environment in the current process.
++ # Unsetting PERL5LIB first ensures that this is the only local::lib in the
++ # environment.
++ $ENV{PERL5LIB} = q{}; ## no critic - localized by caller
++ my $perl_dir = "$cleandir/perl";
++ require local::lib;
++ local::lib->import($perl_dir);
++
++ $self->{perldir} = $perl_dir;
++
++ return;
++ }
++
++ sub run
++ {
++ my ($self) = @_;
++
++ # localize in case we modify this in the below block.
++ local $ENV{PERL5LIB} = $ENV{PERL5LIB};
++
++ if ($self->{clean}) {
++ $self->make_clean_prefix;
++ }
++
++ $self->run_setup_pl;
++ $self->run_prove;
++
++ return;
++ }
++
++ #==============================================================================
++
++ QtQaTest->new(@ARGV)->run if (!caller);
++ 1;