Revision control
++ #!/usr/bin/env perl
++ use strict;
++ use warnings;
++
++ =head1 NAME
++
++ 10-TestScript.t - test QtQA::TestScript module
++
++ =cut
++
++ use FindBin;
++ use lib "$FindBin::Bin/../..";
++
++ use English qw( -no_match_vars );
++ use Data::Dumper qw( Dumper );
++ use IO::CaptureOutput qw( capture );
++ use Test::Exception;
++ use Test::Exit;
++ use Test::More;
++ use Readonly;
++
++ Readonly my $WINDOWS => ($OSNAME =~ m{win32}i);
++
++ BEGIN { use_ok 'QtQA::TestScript'; }
++
++ #==============================================================================
++
++ my %TEST_PERMITTED_PROPERTIES = (
++ 'dog.color' => 'The color of the dog.',
++ 'cat.color' => 'The color of the cat.',
++ 'fish.color'=> 'The color of the fish.',
++ );
++
++ my @TEST_EXE_ARGS1 = (
++ q{arg1},
++ q{arg two},
++ q{arg the third},
++ q{arg 'with quotes'},
++ q{arg "with dquotes"},
++ q{arg with $shell ^meta %characters%},
++ );
++
++ my $TEST_EXE_ARGS1_DUMP = Dumper(\@TEST_EXE_ARGS1);
++
++ # Test that `property' will die in various ways
++ sub test_property_death
++ {
++ my $script = QtQA::TestScript->new;
++
++ # Should die if called before set_permitted_properties
++ throws_ok { $script->property('foo.bar' ) } qr/set_permitted_properties/;
++ throws_ok { $script->property('foo.bar', 'def') } qr/set_permitted_properties/;
++
++ $script->set_permitted_properties(%TEST_PERMITTED_PROPERTIES);
++
++ # Should die if property is not permitted
++ throws_ok { $script->property('bird.color' ) } qr/did not declare it as a permitted property/;
++ throws_ok { $script->property('bird.color', 'def') } qr/did not declare it as a permitted property/;
++
++ # Should die if property is permitted, but is not defined and has no default
++ throws_ok { $script->property('dog.color' ) } qr/default/;
++
++ return;
++ }
++
++ # Test that `property' will use the `default' parameter appropriately
++ sub test_property_get_defaults
++ {
++ my $script = QtQA::TestScript->new;
++ $script->set_permitted_properties(%TEST_PERMITTED_PROPERTIES);
++
++ # Should be able to get defaults
++ my $value;
++ lives_ok { $value = $script->property('dog.color', 'black') };
++ is($value, 'black');
++ lives_ok { $value = $script->property('cat.color', 'white') };
++ is($value, 'white');
++
++ # A repeated call should return the same value (cached)
++ lives_ok { $value = $script->property('dog.color', 'red') };
++ is($value, 'black');
++ lives_ok { $value = $script->property('dog.color') };
++ is($value, 'black');
++
++ return;
++ }
++
++ # Test that `property' will get the property values from environment variables
++ sub test_property_get_from_env
++ {
++ my $script = QtQA::TestScript->new;
++ $script->set_permitted_properties(%TEST_PERMITTED_PROPERTIES);
++
++ my $value;
++
++ {
++ local $ENV{PULSE_DOG_COLOR} = 'grey'; # old style, PULSE
++ local $ENV{QTQA_CAT_COLOR} = 'light blue'; # new style, QTQA
++
++ lives_ok { $value = $script->property('dog.color', 'black') }; # default is ignored
++ is($value, 'grey');
++ lives_ok { $value = $script->property('cat.color') };
++ is($value, 'light blue');
++
++ # And verify that QTQA takes precedence over PULSE
++ local $ENV{QTQA_FISH_COLOR} = 'silver';
++ local $ENV{PULSE_FISH_COLOR} = 'gold';
++
++ lives_ok { $value = $script->property('fish.color') };
++ is($value, 'silver');
++ }
++
++ # A repeated call should return the same value (cached),
++ # even though the ENV vars are no longer set
++ lives_ok { $value = $script->property('dog.color', 'red') }; # default is ignored
++ is($value, 'grey');
++ lives_ok { $value = $script->property('cat.color') };
++ is($value, 'light blue');
++ lives_ok { $value = $script->property('fish.color') };
++ is($value, 'silver');
++
++ return;
++ }
++
++ # Test that `property' will get the properties from command-line arguments
++ sub test_property_get_from_args
++ {
++ my $script = QtQA::TestScript->new;
++ $script->set_permitted_properties(%TEST_PERMITTED_PROPERTIES);
++
++ my @args = ('--dog-color', 'green', '--cat-color', 'dark red');
++ $script->get_options_from_array(\@args);
++
++ my $value;
++ lives_ok { $value = $script->property('dog.color', 'black') }; # default is ignored
++ is($value, 'green');
++ lives_ok { $value = $script->property('cat.color') };
++ is($value, 'dark red');
++
++ return;
++ }
++
++ # Trivial test of default_common_property function
++ sub test_default_common_property
++ {
++ my $script = QtQA::TestScript->new;
++
++ # Here, we basically test that default common properties returns
++ # anything at all for a known property, and nothing for an unknown property.
++ # We don't attempt to test the actual value returned (since the whole point
++ # of this function is that the value may be unpredictable).
++ ok( $script->default_common_property('base.dir'), 'base.dir has a default' );
++ is( $script->default_common_property('fake.property'), undef, 'fake.property has no default' );
++
++ return;
++ }
++
++ # Test interaction between `print_verbose' and `--verbose' command-line option
++ sub test_verbosity
++ {
++ my $script = QtQA::TestScript->new;
++
++ my $stdout;
++ my $stderr;
++
++ capture { $script->print_when_verbose(0, "hello", "world") } \$stdout, \$stderr;
++ is( $stdout, "helloworld" );
++ is( $stderr, "" );
++
++ capture { $script->print_when_verbose(-10, "negative") } \$stdout, \$stderr;
++ is( $stdout, "negative" );
++ is( $stderr, "" );
++
++ capture { $script->print_when_verbose(1, "should not print") } \$stdout, \$stderr;
++ is( $stdout, "" );
++ is( $stderr, "" );
++
++ # Should set verbosity to 2
++ $script->get_options_from_array(['--verbose', '--verbose']);
++
++ capture { $script->print_when_verbose(1, "should print") } \$stdout, \$stderr;
++ is( $stdout, "should print" );
++ is( $stderr, "" );
++
++ capture { $script->print_when_verbose(2, "again print") } \$stdout, \$stderr;
++ is( $stdout, "again print" );
++ is( $stderr, "" );
++
++ capture { $script->print_when_verbose(3, "silent") } \$stdout, \$stderr;
++ is( $stdout, "" );
++ is( $stderr, "" );
++
++ return;
++ }
++
++ # Basic test of command-line parsing
++ sub test_get_options_from_array
++ {
++ my $script = QtQA::TestScript->new;
++
++ # `--help' is tested by 20-TestScript-autodocs.t
++ # `--verbose' is tested by test_verbosity
++ # passing arguments for properties is tested by test_property_get_from_args
++
++ # Here, we're just testing that our arguments are passed to getopt unmolested.
++ my $value1;
++ my $value2;
++ my @args = (
++ '--option-one', 'A string',
++ '--option-two',
++ 'something else',
++ );
++ $script->get_options_from_array(\@args,
++ 'option-one=s' => \$value1,
++ 'option-two' => \$value2,
++ );
++
++ is( $value1, 'A string' );
++ is( $value2, 1 );
++ is( scalar(@args), 1 ); # non-parsed option is left behind
++ is( $args[0], 'something else' );
++
++ return;
++ }
++
++ # Test that exe logs, dies and passes arguments correctly
++ sub test_exe
++ {
++ my $script = QtQA::TestScript->new;
++
++ # Any non-zero exit code should make the script die
++ local $? = 0;
++ dies_ok( sub { $script->exe('/bin/false') }, 'non-zero exit code implies death' );
++ isnt( $?, 0, 'non-zero exit code is passed through $?' );
++
++ my $stdout;
++ my $stderr;
++
++ my @good_cmd = (
++ 'perl',
++ '-e',
++ 'use Data::Dumper; print Dumper(\@ARGV);',
++ @TEST_EXE_ARGS1,
++ );
++ my $expected_log = "+ @good_cmd\n$TEST_EXE_ARGS1_DUMP";
++
++ # We invoke a subprocess which uses Data::Dumper to print out all
++ # arguments. This is a simple way to check unambiguously what args
++ # were received.
++ local $? = 1;
++ lives_ok( sub { capture { $script->exe(@good_cmd) } \$stdout, \$stderr },
++ 'successful command lives');
++ is( $?, 0, 'zero exit code is passed through $?' );
++
++ TODO: {
++ local $TODO = 'fix or document argument passing on Windows' if $WINDOWS;
++ is( $stdout, $expected_log, 'exe passes arguments correctly' );
++ }
++ is( $stderr, q{}, 'no unexpected warnings or stderr' );
++
++ # If verbose, should print out the command being run
++ $script->get_options_from_array(['--verbose']);
++ lives_ok( sub { capture { $script->exe(@good_cmd) } \$stdout, \$stderr },
++ 'successful command lives (verbose)');
++
++ # exe should print out one line before running the command, like this:
++ # + cmd with each arg separated by space
++ # Note it currently does not attempt to print args with whitespace unambiguously
++ TODO: {
++ local $TODO = 'fix or document argument passing on Windows' if $WINDOWS;
++ is( $stdout, $expected_log, 'exe logs correctly' );
++ }
++ is( $stderr, q{}, 'no unexpected warnings or stderr' );
++
++ # verify that an exit status is passed into $? correctly
++ my @exit12_cmd = (
++ 'perl',
++ '-e',
++ 'exit(12)',
++ );
++ local $? = 0;
++ dies_ok( sub { $script->exe(@exit12_cmd) }, 'exit(12) implies death' );
++ is( $?, (12 << 8), 'correct exit code is passed through $?' );
++
++ return;
++ }
++
++ # Test that exe_qx works like exe and also captures output.
++ sub test_exe_qx
++ {
++ my $script = QtQA::TestScript->new;
++
++ # Any non-zero exit code should make the script die
++ local $? = 0;
++ dies_ok( sub { $script->exe_qx('/bin/false') }, 'non-zero exit code implies death' );
++ isnt( $?, 0, 'non-zero exit code is passed through $?' );
++
++ # Note that there are two sets of output: the output from the child process
++ # (which we expect to be returned), and the output from this process
++ # (which is empty in the non-verbose case, and should never be returned).
++
++ # From child process:
++ my $stdout;
++ my $stderr;
++ my $merged;
++
++ # From this process:
++ my $log_stdout;
++ my $log_stderr;
++
++ my $test_stdout = $TEST_EXE_ARGS1_DUMP;
++ my $test_stderr = "Some stderr\n";
++ my $test_merged = $test_stdout.$test_stderr;
++
++ my @good_cmd = (
++ 'perl',
++ '-e',
++ '$|++; use Data::Dumper; print Dumper(\@ARGV); print STDERR qq{Some stderr\n};',
++ @TEST_EXE_ARGS1,
++ );
++
++ local $? = 1;
++ lives_ok(
++ sub {
++ capture { ($stdout, $stderr) = $script->exe_qx(@good_cmd) } \$log_stdout, \$log_stderr;
++ capture { $merged = $script->exe_qx(@good_cmd) }; # discard any log output
++ },
++ 'successful command lives'
++ );
++ is( $?, 0, 'zero exit code is passed through $?' );
++
++ TODO: {
++ local $TODO = 'fix or document argument passing on Windows' if $WINDOWS;
++ is( $stdout, $test_stdout, 'exe_qx passes arguments correctly' );
++ is( $merged, $test_merged, 'merged output OK' );
++ }
++ is( $stderr, $test_stderr, 'stderr OK' );
++
++ ok( !$log_stdout, 'no log output (verbose1)' );
++ ok( !$log_stderr, 'no log error (verbose1)' );
++
++
++
++ # If verbose 1, command will be logged before it is run.
++ $script->get_options_from_array(['--verbose']);
++
++ lives_ok(
++ sub {
++ capture { ($stdout, $stderr) = $script->exe_qx(@good_cmd) } \$log_stdout, \$log_stderr;
++ capture { $merged = $script->exe_qx(@good_cmd) }; # discard any log output
++ },
++ 'successful command lives (verbose1)'
++ );
++
++ is( $stderr, $test_stderr, 'stderr OK (verbose1)' );
++ TODO: {
++ local $TODO = 'fix or document argument passing on Windows' if $WINDOWS;
++ is( $stdout, $test_stdout, 'exe_qx passes arguments correctly (verbose1)' );
++ is( $merged, $test_merged, 'merged output OK (verbose1)' );
++ }
++
++ is( $log_stdout, "qx @good_cmd\n", 'log output OK (verbose1)' );
++ ok( !$log_stderr, 'no log error (verbose1)' );
++
++
++
++ # If verbose 2, command will be logged before it is run, and stdout/stderr is logged
++ # after it is run. We need to test the log for merged vs non-merged independently here.
++ $script->get_options_from_array(['--verbose']);
++
++ my $log_stdout_merged;
++ my $log_stderr_merged;
++
++ my $expected_log_stdout = "qx @good_cmd\n" . <<'EOF';
++ qx stdout:
++ $VAR1 = [
++ 'arg1',
++ 'arg two',
++ 'arg the third',
++ 'arg \'with quotes\'',
++ 'arg "with dquotes"',
++ 'arg with $shell ^meta %characters%'
++ ];
++
++ qx stderr:
++ Some stderr
++
++ EOF
++
++ my $expected_log_stdout_merged = "qx @good_cmd\n" . <<'EOF';
++ qx stdout & stderr:
++ $VAR1 = [
++ 'arg1',
++ 'arg two',
++ 'arg the third',
++ 'arg \'with quotes\'',
++ 'arg "with dquotes"',
++ 'arg with $shell ^meta %characters%'
++ ];
++ Some stderr
++
++ EOF
++
++ lives_ok(
++ sub {
++ capture { ($stdout, $stderr) = $script->exe_qx(@good_cmd) }
++ \$log_stdout, \$log_stderr;
++
++ capture { $merged = $script->exe_qx(@good_cmd) }
++ \$log_stdout_merged, \$log_stderr_merged;
++ },
++ 'successful command lives (verbose2)'
++ );
++
++ is( $stderr, $test_stderr, 'stderr OK (verbose2)' );
++ ok( !$log_stderr, 'no log error (verbose2)' );
++ ok( !$log_stderr_merged, 'no log error (verbose2, merged)' );
++ TODO: {
++ local $TODO = 'fix or document argument passing on Windows' if $WINDOWS;
++ is( $stdout, $test_stdout, 'exe_qx passes arguments correctly (verbose2)' );
++ is( $merged, $test_merged, 'merged output OK (verbose2)' );
++ is( $log_stdout, $expected_log_stdout, 'log output OK (verbose2)' );
++ is( $log_stdout_merged, $expected_log_stdout_merged, 'log output OK (verbose2, merged)' );
++ }
++
++ # verify that an exit status is passed into $? correctly
++ my @exit12_cmd = (
++ 'perl',
++ '-e',
++ 'exit(12)',
++ );
++ local $? = 0;
++ dies_ok( sub { $script->exe_qx(@exit12_cmd) }, 'exit(12) implies death' );
++ is( $?, (12 << 8), 'correct exit code is passed through $?' );
++
++ return;
++ }
++
++ sub test_fatal_error
++ {
++ my $script = QtQA::TestScript->new;
++
++ throws_ok {
++ $script->fatal_error(
++ "Error occurred while making sandwich:\n"
++ ."Somebody left the fridge door open all weekend\n"
++ );
++ } qr{
++
++ # Note it is OK to have some stuff before and after the YAML.
++ # However, the header must always be on its own line and the
++ # footer must always be followed by a newline.
++
++ (?:\n|\A)
++ \Q--- !qtqa.qt-project.org/error
++ message: |
++ Error occurred while making sandwich:
++ Somebody left the fridge door open all weekend
++ ... \E\#\Q end qtqa.qt-project.org/error\E
++ (?:\n|\z)
++
++ }xms, 'fatal_error output looks OK';
++
++ return;
++ }
++
++ sub test_fail
++ {
++ my $script = QtQA::TestScript->new;
++
++ throws_ok {
++ $script->fail(
++ "Error occurred while making sandwich:\n"
++ ."Somebody left the fridge door open all weekend\n"
++ );
++ } qr{
++
++ (?:\n|\A)
++ \Q--- !qtqa.qt-project.org/failure
++ message: |
++ Error occurred while making sandwich:
++ Somebody left the fridge door open all weekend
++ ... \E\#\Q end qtqa.qt-project.org/failure\E
++ (?:\n|\z)
++
++ }xms, 'fail output looks OK';
++
++ return;
++ }
++
++ sub test_doing
++ {
++ my $script = QtQA::TestScript->new;
++
++ my $make_expected = sub {
++ my ($type, $message, @scopes) = @_;
++ @scopes = reverse @scopes;
++ return
++ "--- !qtqa.qt-project.org/$type\nmessage: $message\n"
++ .(@scopes
++ ? "while:\n - "
++ .join("\n - ", @scopes)
++ ."\n"
++ : q{}
++ )
++ ."... # end qtqa.qt-project.org/$type\n";
++ };
++
++ my $expected_error_for_scopes = sub { return $make_expected->( 'error', @_ ) };
++ my $expected_failure_for_scopes = sub { return $make_expected->( 'failure', @_ ) };
++
++ {
++ my $outer = $script->doing( 'outer1' );
++
++ {
++ my $inner1 = $script->doing( 'inner1' );
++ my $expected = $expected_error_for_scopes->( 'quux', 'outer1', 'inner1' );
++ throws_ok { $script->fatal_error( 'quux' ) } qr{\A\Q$expected\E}, 'two scopes';
++ }
++
++ my $expected = $expected_failure_for_scopes->( 'bar', 'outer1' );
++ throws_ok { $script->fail( 'bar' ) } qr{\A\Q$expected\E}, 'one scope';
++ }
++
++ my $expected = $expected_error_for_scopes->( 'baz' );
++ throws_ok { $script->fatal_error( 'baz' ) } qr{\A\Q$expected\E}, 'no scope';
++
++ return;
++ }
++
++ # Run all the tests
++ sub run_test
++ {
++ test_property_death;
++ test_property_get_defaults;
++ test_property_get_from_env;
++ test_property_get_from_args;
++
++ test_default_common_property;
++
++ test_verbosity;
++
++ test_get_options_from_array;
++
++ test_exe;
++ test_exe_qx;
++
++ test_fatal_error;
++ test_fail;
++ test_doing;
++
++ return;
++ }
++
++ #==============================================================================
++
++ if (!caller) {
++ run_test;
++ done_testing;
++ }
++ 1;