[p5sagit/p5-mst-13.2.git] / lib / Test / Harness / t / harness.t

#!/usr/bin/perl -w

BEGIN {
    if( $ENV{PERL_CORE} ) {
        chdir 't';
        @INC = ('../lib', 'lib');
    }
    else {
	use lib 't/lib';
    }
}

BEGIN {
    if ($ENV{PERL_CORE}) {
	# FIXME
	print "1..0 # Skip pending resolution of a clean way to record the change in location of the sample tests\n";
	exit 0;
    }
}

use strict;

use Test::More;
use IO::c55Capture;

use TAP::Harness;

my $HARNESS = 'TAP::Harness';

plan tests => 106;

# note that this test will always pass when run through 'prove'
ok $ENV{HARNESS_ACTIVE},  'HARNESS_ACTIVE env variable should be set';
ok $ENV{HARNESS_VERSION}, 'HARNESS_VERSION env variable should be set';

#### For color tests ####

package Colorizer;

sub new { bless {}, shift }
sub can_color {1}

sub set_color {
    my ( $self, $output, $color ) = @_;
    $output->("[[$color]]");
}

package main;

sub colorize {
    my $harness = shift;
    $harness->formatter->_colorizer( Colorizer->new );
}

can_ok $HARNESS, 'new';

eval { $HARNESS->new( { no_such_key => 1 } ) };
like $@, qr/\QUnknown arguments to TAP::Harness::new (no_such_key)/,
  '... and calling it with bad keys should fail';

eval { $HARNESS->new( { lib => 'aint_no_such_lib' } ) };
is $@, '', '... and calling it with a non-existent lib is fine';

eval { $HARNESS->new( { lib => [qw/bad_lib_1 bad_lib_2/] } ) };
is $@, '', '... and calling it with non-existent libs is fine';

ok my $harness = $HARNESS->new,
  'Calling new() without arguments should succeed';

foreach my $test_args ( get_arg_sets() ) {
    my %args = %$test_args;
    foreach my $key ( sort keys %args ) {
        $args{$key} = $args{$key}{in};
    }
    ok my $harness = $HARNESS->new( {%args} ),
      'Calling new() with valid arguments should succeed';
    isa_ok $harness, $HARNESS, '... and the object it returns';

    while ( my ( $property, $test ) = each %$test_args ) {
        my $value = $test->{out};
        can_ok $harness, $property;
        is_deeply scalar $harness->$property(), $value, $test->{test_name};
    }
}

{
    my @output;
    local $^W;
    local *TAP::Formatter::Console::_should_show_count = sub {0};
    local *TAP::Formatter::Console::_output = sub {
        my $self = shift;
        push @output => grep { $_ ne '' }
          map {
            local $_ = $_;
            chomp;
            trim($_)
          } @_;
    };
    my $harness            = TAP::Harness->new( { verbosity  => 1 } );
    my $harness_whisper    = TAP::Harness->new( { verbosity  => -1 } );
    my $harness_mute       = TAP::Harness->new( { verbosity  => -2 } );
    my $harness_directives = TAP::Harness->new( { directives => 1 } );
    my $harness_failures   = TAP::Harness->new( { failures   => 1 } );

    colorize($harness);

    can_ok $harness, 'runtests';

    # normal tests in verbose mode

    ok my $aggregate = _runtests( $harness, 't/source_tests/harness' ),
      '... runtests returns the aggregate';

    isa_ok $aggregate, 'TAP::Parser::Aggregator';

    chomp(@output);

    my @expected = (
        't/source_tests/harness....',
        '1..1',
        '[[reset]]',
        'ok 1 - this is a test',
        '[[reset]]',
        'ok',
        'All tests successful.',
    );
    my $status           = pop @output;
    my $expected_status  = qr{^Result: PASS$};
    my $summary          = pop @output;
    my $expected_summary = qr{^Files=1, Tests=1,  \d+ wallclock secs};

    is_deeply \@output, \@expected, '... and the output should be correct';
    like $status, $expected_status,
      '... and the status line should be correct';
    like $summary, $expected_summary,
      '... and the report summary should look correct';

    # use an alias for test name

    @output = ();
    ok $aggregate
      = _runtests( $harness, [ 't/source_tests/harness', 'My Nice Test' ] ),
      '... runtests returns the aggregate';

    isa_ok $aggregate, 'TAP::Parser::Aggregator';

    chomp(@output);

    @expected = (
        'My Nice Test....',
        '1..1',
        '[[reset]]',
        'ok 1 - this is a test',
        '[[reset]]',
        'ok',
        'All tests successful.',
    );
    $status           = pop @output;
    $expected_status  = qr{^Result: PASS$};
    $summary          = pop @output;
    $expected_summary = qr{^Files=1, Tests=1,  \d+ wallclock secs};

    is_deeply \@output, \@expected, '... and the output should be correct';
    like $status, $expected_status,
      '... and the status line should be correct';
    like $summary, $expected_summary,
      '... and the report summary should look correct';

    # run same test twice

    @output = ();
    ok $aggregate
      = _runtests( $harness, [ 't/source_tests/harness', 'My Nice Test' ],
        [ 't/source_tests/harness', 'My Nice Test Again' ] ),
      '... runtests returns the aggregate';

    isa_ok $aggregate, 'TAP::Parser::Aggregator';

    chomp(@output);

    @expected = (
        'My Nice Test..........',
        '1..1',
        '[[reset]]',
        'ok 1 - this is a test',
        '[[reset]]',
        'ok',
        'My Nice Test Again....',
        '1..1',
        '[[reset]]',
        'ok 1 - this is a test',
        '[[reset]]',
        'ok',
        'All tests successful.',
    );
    $status           = pop @output;
    $expected_status  = qr{^Result: PASS$};
    $summary          = pop @output;
    $expected_summary = qr{^Files=2, Tests=2,  \d+ wallclock secs};

    is_deeply \@output, \@expected, '... and the output should be correct';
    like $status, $expected_status,
      '... and the status line should be correct';
    like $summary, $expected_summary,
      '... and the report summary should look correct';

    # normal tests in quiet mode

    @output = ();
    _runtests( $harness_whisper, 't/source_tests/harness' );

    chomp(@output);
    @expected = (
        't/source_tests/harness....',
        'ok',
        'All tests successful.',
    );

    $status           = pop @output;
    $expected_status  = qr{^Result: PASS$};
    $summary          = pop @output;
    $expected_summary = qr/^Files=1, Tests=1,  \d+ wallclock secs/;

    is_deeply \@output, \@expected, '... and the output should be correct';
    like $status, $expected_status,
      '... and the status line should be correct';
    like $summary, $expected_summary,
      '... and the report summary should look correct';

    # normal tests in really_quiet mode

    @output = ();
    _runtests( $harness_mute, 't/source_tests/harness' );

    chomp(@output);
    @expected = (
        'All tests successful.',
    );

    $status           = pop @output;
    $expected_status  = qr{^Result: PASS$};
    $summary          = pop @output;
    $expected_summary = qr/^Files=1, Tests=1,  \d+ wallclock secs/;

    is_deeply \@output, \@expected, '... and the output should be correct';
    like $status, $expected_status,
      '... and the status line should be correct';
    like $summary, $expected_summary,
      '... and the report summary should look correct';

    # normal tests with failures

    @output = ();
    _runtests( $harness, 't/source_tests/harness_failure' );

    $status  = pop @output;
    $summary = pop @output;

    like $status, qr{^Result: FAIL$},
      '... and the status line should be correct';

    my @summary = @output[ 10 .. $#output ];
    @output = @output[ 0 .. 9 ];

    @expected = (
        't/source_tests/harness_failure....',
        '1..2',
        '[[reset]]',
        'ok 1 - this is a test',
        '[[reset]]',
        '[[red]]',
        'not ok 2 - this is another test',
        '[[reset]]',
        '[[red]]',
        'Failed 1/2 subtests',
    );

    is_deeply \@output, \@expected,
      '... and failing test output should be correct';

    my @expected_summary = (
        '[[reset]]',
        'Test Summary Report',
        '-------------------',
        '[[red]]',
        't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)',
        '[[reset]]',
        '[[red]]',
        'Failed test:',
        '[[reset]]',
        '[[red]]',
        '2',
        '[[reset]]',
    );

    is_deeply \@summary, \@expected_summary,
      '... and the failure summary should also be correct';

    # quiet tests with failures

    @output = ();
    _runtests( $harness_whisper, 't/source_tests/harness_failure' );

    $status   = pop @output;
    $summary  = pop @output;
    @expected = (
        't/source_tests/harness_failure....',
        'Failed 1/2 subtests',
        'Test Summary Report',
        '-------------------',
        't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)',
        'Failed test:',
        '2',
    );

    like $status, qr{^Result: FAIL$},
      '... and the status line should be correct';

    is_deeply \@output, \@expected,
      '... and failing test output should be correct';

    # really quiet tests with failures

    @output = ();
    _runtests( $harness_mute, 't/source_tests/harness_failure' );

    $status   = pop @output;
    $summary  = pop @output;
    @expected = (
        'Test Summary Report',
        '-------------------',
        't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)',
        'Failed test:',
        '2',
    );

    like $status, qr{^Result: FAIL$},
      '... and the status line should be correct';

    is_deeply \@output, \@expected,
      '... and failing test output should be correct';

    # only show directives

    @output = ();
    _runtests(
        $harness_directives,
        't/source_tests/harness_directives'
    );

    chomp(@output);

    @expected = (
        't/source_tests/harness_directives....',
        'not ok 2 - we have a something # TODO some output',
        "ok 3 houston, we don't have liftoff # SKIP no funding",
        'ok',
        'All tests successful.',

        # ~TODO {{{ this should be an option
        #'Test Summary Report',
        #'-------------------',
        #'t/source_tests/harness_directives (Wstat: 0 Tests: 3 Failed: 0)',
        #'Tests skipped:',
        #'3',
        # }}}
    );

    $status           = pop @output;
    $summary          = pop @output;
    $expected_summary = qr/^Files=1, Tests=3,  \d+ wallclock secs/;

    is_deeply \@output, \@expected, '... and the output should be correct';
    like $summary, $expected_summary,
      '... and the report summary should look correct';

    like $status, qr{^Result: PASS$},
      '... and the status line should be correct';

    # normal tests with bad tap

    # install callback handler
    my $parser;
    my $callback_count = 0;

    my @callback_log = ();

    for my $evt (qw(parser_args made_parser before_runtests after_runtests)) {
        $harness->callback(
            $evt => sub {
                push @callback_log, $evt;
            }
        );
    }

    $harness->callback(
        made_parser => sub {
            $parser = shift;
            $callback_count++;
        }
    );

    @output = ();
    _runtests( $harness, 't/source_tests/harness_badtap' );
    chomp(@output);

    @output   = map { trim($_) } @output;
    $status   = pop @output;
    @summary  = @output[ 12 .. ( $#output - 1 ) ];
    @output   = @output[ 0 .. 11 ];
    @expected = (
        't/source_tests/harness_badtap....',
        '1..2',
        '[[reset]]',
        'ok 1 - this is a test',
        '[[reset]]',
        '[[red]]',
        'not ok 2 - this is another test',
        '[[reset]]',
        '1..2',
        '[[reset]]',
        '[[red]]',
        'Failed 1/2 subtests',
    );
    is_deeply \@output, \@expected,
      '... and failing test output should be correct';
    like $status, qr{^Result: FAIL$},
      '... and the status line should be correct';
    @expected_summary = (
        '[[reset]]',
        'Test Summary Report',
        '-------------------',
        '[[red]]',
        't/source_tests/harness_badtap (Wstat: 0 Tests: 2 Failed: 1)',
        '[[reset]]',
        '[[red]]',
        'Failed test:',
        '[[reset]]',
        '[[red]]',
        '2',
        '[[reset]]',
        '[[red]]',
        'Parse errors: More than one plan found in TAP output',
        '[[reset]]',
    );
    is_deeply \@summary, \@expected_summary,
      '... and the badtap summary should also be correct';

    cmp_ok( $callback_count, '==', 1, 'callback called once' );
    is_deeply(
        \@callback_log,
        [ 'before_runtests', 'parser_args', 'made_parser', 'after_runtests' ],
        'callback log matches'
    );
    isa_ok $parser, 'TAP::Parser';

    # coverage testing for _should_show_failures
    # only show failures

    @output = ();
    _runtests( $harness_failures, 't/source_tests/harness_failure' );

    chomp(@output);

    @expected = (
        't/source_tests/harness_failure....',
        'not ok 2 - this is another test',
        'Failed 1/2 subtests',
        'Test Summary Report',
        '-------------------',
        't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)',
        'Failed test:',
        '2',
    );

    $status  = pop @output;
    $summary = pop @output;

    like $status, qr{^Result: FAIL$},
      '... and the status line should be correct';
    $expected_summary = qr/^Files=1, Tests=2,  \d+ wallclock secs/;
    is_deeply \@output, \@expected, '... and the output should be correct';

    # check the status output for no tests

    @output = ();
    _runtests( $harness_failures, 't/sample-tests/no_output' );

    chomp(@output);

    @expected = (
        't/sample-tests/no_output....',
        'No subtests run',
        'Test Summary Report',
        '-------------------',
        't/sample-tests/no_output (Wstat: 0 Tests: 0 Failed: 0)',
        'Parse errors: No plan found in TAP output',
    );

    $status  = pop @output;
    $summary = pop @output;

    like $status, qr{^Result: FAIL$},
      '... and the status line should be correct';
    $expected_summary = qr/^Files=1, Tests=2,  \d+ wallclock secs/;
    is_deeply \@output, \@expected, '... and the output should be correct';

    #XXXX
}

# make sure we can exec something ... anything!
SKIP: {

    my $cat = '/bin/cat';
    unless ( -e $cat ) {
        skip "no '$cat'", 2;
    }

    my $capture = IO::c55Capture->new_handle;
    my $harness = TAP::Harness->new(
        {   verbosity => -2,
            stdout    => $capture,
            exec      => [$cat],
        }
    );

    eval { _runtests( $harness, 't/data/catme.1' ) };

    my @output = tied($$capture)->dump;
    my $status = pop @output;
    like $status, qr{^Result: PASS$},
      '... and the status line should be correct';
    pop @output;    # get rid of summary line
    my $answer = pop @output;
    is( $answer, "All tests successful.\n", 'cat meows' );
}

# catches "exec accumulates arguments" issue (r77)
{
    my $capture = IO::c55Capture->new_handle;
    my $harness = TAP::Harness->new(
        {   verbosity => -2,
            stdout    => $capture,
            exec      => [$^X]
        }
    );

    _runtests(
        $harness,
        't/source_tests/harness_complain'
        ,    # will get mad if run with args
        't/source_tests/harness',
    );

    my @output = tied($$capture)->dump;
    my $status = pop @output;
    like $status, qr{^Result: PASS$},
      '... and the status line should be correct';
    pop @output;    # get rid of summary line
    is( $output[-1], "All tests successful.\n",
        'No exec accumulation'
    );
}

sub trim {
    $_[0] =~ s/^\s+|\s+$//g;
    return $_[0];
}

sub liblist {
    return [ map {"-I$_"} @_ ];
}

sub get_arg_sets {

    # keys are keys to new()
    return {
        lib => {
            in        => 'lib',
            out       => liblist('lib'),
            test_name => '... a single lib switch should be correct'
        },
        verbosity => {
            in        => 1,
            out       => 1,
            test_name => '... and we should be able to set verbosity to 1'
        },

        # verbose => {
        #     in        => 1,
        #     out       => 1,
        #     test_name => '... and we should be able to set verbose to true'
        # },
      },
      { lib => {
            in        => [ 'lib',        't' ],
            out       => liblist( 'lib', 't' ),
            test_name => '... multiple lib dirs should be correct'
        },
        verbosity => {
            in        => 0,
            out       => 0,
            test_name => '... and we should be able to set verbosity to 0'
        },

        # verbose => {
        #     in        => 0,
        #     out       => 0,
        #     test_name => '... and we should be able to set verbose to false'
        # },
      },
      { switches => {
            in        => [ '-T', '-w', '-T' ],
            out       => [ '-T', '-w', '-T' ],
            test_name => '... duplicate switches should remain',
        },
        failures => {
            in  => 1,
            out => 1,
            test_name =>
              '... and we should be able to set failures to true',
        },
        verbosity => {
            in        => -1,
            out       => -1,
            test_name => '... and we should be able to set verbosity to -1'
        },

        # quiet => {
        #     in        => 1,
        #     out       => 1,
        #     test_name => '... and we should be able to set quiet to false'
        # },
      },

      { verbosity => {
            in        => -2,
            out       => -2,
            test_name => '... and we should be able to set verbosity to -2'
        },

        # really_quiet => {
        #     in  => 1,
        #     out => 1,
        #     test_name =>
        #       '... and we should be able to set really_quiet to true',
        # },
        exec => {
            in  => $^X,
            out => $^X,
            test_name =>
              '... and we should be able to set the executable',
        },
      },
      { switches => {
            in  => 'T',
            out => ['T'],
            test_name =>
              '... leading dashes (-) on switches are not optional',
        },
      },
      { switches => {
            in        => '-T',
            out       => ['-T'],
            test_name => '... we should be able to set switches',
        },
        failures => {
            in        => 1,
            out       => 1,
            test_name => '... and we should be able to set failures to true'
        },
      };
}

sub _runtests {
    my ( $harness, @tests ) = @_;
    local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0;
    my $aggregate = $harness->runtests(@tests);
    return $aggregate;
}

{

    # coverage tests for ctor

    my $harness = TAP::Harness->new(
        {   timer  => 0,
            errors => 1,
            merge  => 2,

            # formatter => 3,
        }
    );

    is $harness->timer(), 0, 'timer getter';
    is $harness->timer(10), 10, 'timer setter';
    is $harness->errors(), 1, 'errors getter';
    is $harness->errors(10), 10, 'errors setter';
    is $harness->merge(), 2, 'merge getter';
    is $harness->merge(10), 10, 'merge setter';

    # jobs accessor
    is $harness->jobs(), 1, 'jobs';
}

{

# coverage tests for the stdout key of VALIDATON_FOR, used by _initialize() in the ctor

    # the coverage tests are
    # 1. ref $ref => false
    # 2. ref => ! GLOB and ref->can(print)
    # 3. ref $ref => GLOB

    # case 1

    my @die;

    eval {
        local $SIG{__DIE__} = sub { push @die, @_ };

        my $harness = TAP::Harness->new(
            {   stdout => bless {}, '0',    # how evil is THAT !!!
            }
        );
    };

    is @die, 1, 'bad filehandle to stdout';
    like pop @die, qr/option 'stdout' needs a filehandle/,
      '... and we died as expected';

    # case 2

    @die = ();

    package Printable;

    sub new { return bless {}, shift }

    sub print {return}

    package main;

    my $harness = TAP::Harness->new(
        {   stdout => Printable->new(),
        }
    );

    isa_ok $harness, 'TAP::Harness';

    # case 3

    @die = ();

    $harness = TAP::Harness->new(
        {   stdout => bless {}, 'GLOB',    # again with the evil
        }
    );

    isa_ok $harness, 'TAP::Harness';
}

{

    # coverage testing of lib/switches accessor
    my $harness = TAP::Harness->new;

    my @die;

    eval {
        local $SIG{__DIE__} = sub { push @die, @_ };

        $harness->switches(qw( too many arguments));
    };

    is @die, 1, 'too many arguments to accessor';

    like pop @die, qr/Too many arguments to method 'switches'/,
      '...and we died as expected';

    $harness->switches('simple scalar');

    my $arrref = $harness->switches;
    is_deeply $arrref, ['simple scalar'], 'scalar wrapped in arr ref';
}

{

    # coverage tests for the basically untested T::H::_open_spool

    $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(qw(t spool));

# now given that we're going to be writing stuff to the file system, make sure we have
# a cleanup hook

    END {
        use File::Path;

        # remove the tree if we made it this far
        rmtree( $ENV{PERL_TEST_HARNESS_DUMP_TAP} )
          if $ENV{PERL_TEST_HARNESS_DUMP_TAP};
    }

    my $harness = TAP::Harness->new( { verbosity => -2 } );

    can_ok $harness, 'runtests';

    # normal tests in verbose mode

    my $parser = $harness->runtests(
        File::Spec->catfile(qw (t source_tests harness )) );

    isa_ok $parser, 'TAP::Parser::Aggregator',
      '... runtests returns the aggregate';

    ok -e File::Spec->catfile(
        $ENV{PERL_TEST_HARNESS_DUMP_TAP},
        qw( t source_tests harness )
    );
}
Commit	Line	Data
b965d173	1	#!/usr/bin/perl -w
3c87ea76	2
3c87ea76	3	BEGIN {
b965d173	4	if( $ENV{PERL_CORE} ) {
3c87ea76	5	chdir 't';
	6	@INC = ('../lib', 'lib');
	7	}
	8	else {
b965d173	9	use lib 't/lib';
	10	}
	11	}
	12
	13	BEGIN {
	14	if ($ENV{PERL_CORE}) {
	15	# FIXME
	16	print "1..0 # Skip pending resolution of a clean way to record the change in location of the sample tests\n";
	17	exit 0;
3c87ea76	18	}
	19	}
	20
	21	use strict;
	22
b965d173	23	use Test::More;
b965d173	24	use IO::c55Capture;
3c87ea76	25
b965d173	26	use TAP::Harness;
	27
	28	my $HARNESS = 'TAP::Harness';
	29
	30	plan tests => 106;
	31
	32	# note that this test will always pass when run through 'prove'
	33	ok $ENV{HARNESS_ACTIVE}, 'HARNESS_ACTIVE env variable should be set';
	34	ok $ENV{HARNESS_VERSION}, 'HARNESS_VERSION env variable should be set';
	35
	36	#### For color tests ####
	37
	38	package Colorizer;
	39
	40	sub new { bless {}, shift }
	41	sub can_color {1}
	42
	43	sub set_color {
	44	my ( $self, $output, $color ) = @_;
	45	$output->("[[$color]]");
	46	}
	47
	48	package main;
	49
	50	sub colorize {
	51	my $harness = shift;
	52	$harness->formatter->_colorizer( Colorizer->new );
	53	}
	54
	55	can_ok $HARNESS, 'new';
	56
	57	eval { $HARNESS->new( { no_such_key => 1 } ) };
	58	like $@, qr/\QUnknown arguments to TAP::Harness::new (no_such_key)/,
	59	'... and calling it with bad keys should fail';
	60
	61	eval { $HARNESS->new( { lib => 'aint_no_such_lib' } ) };
	62	is $@, '', '... and calling it with a non-existent lib is fine';
	63
	64	eval { $HARNESS->new( { lib => [qw/bad_lib_1 bad_lib_2/] } ) };
	65	is $@, '', '... and calling it with non-existent libs is fine';
	66
	67	ok my $harness = $HARNESS->new,
	68	'Calling new() without arguments should succeed';
	69
	70	foreach my $test_args ( get_arg_sets() ) {
	71	my %args = %$test_args;
	72	foreach my $key ( sort keys %args ) {
	73	$args{$key} = $args{$key}{in};
	74	}
	75	ok my $harness = $HARNESS->new( {%args} ),
	76	'Calling new() with valid arguments should succeed';
	77	isa_ok $harness, $HARNESS, '... and the object it returns';
	78
	79	while ( my ( $property, $test ) = each %$test_args ) {
	80	my $value = $test->{out};
	81	can_ok $harness, $property;
	82	is_deeply scalar $harness->$property(), $value, $test->{test_name};
	83	}
	84	}
	85
	86	{
	87	my @output;
	88	local $^W;
	89	local *TAP::Formatter::Console::_should_show_count = sub {0};
90	local *TAP::Formatter::Console::_output = sub {
91	my $self = shift;
92	push @output => grep { $_ ne '' }
93	map {
94	local $_ = $_;
95	chomp;
96	trim($_)
97	} @_;
98	};
99	my $harness = TAP::Harness->new( { verbosity => 1 } );
100	my $harness_whisper = TAP::Harness->new( { verbosity => -1 } );
101	my $harness_mute = TAP::Harness->new( { verbosity => -2 } );
102	my $harness_directives = TAP::Harness->new( { directives => 1 } );
103	my $harness_failures = TAP::Harness->new( { failures => 1 } );
104
105	colorize($harness);
106
107	can_ok $harness, 'runtests';
108
109	# normal tests in verbose mode
110
111	ok my $aggregate = _runtests( $harness, 't/source_tests/harness' ),
112	'... runtests returns the aggregate';
113
114	isa_ok $aggregate, 'TAP::Parser::Aggregator';
115
116	chomp(@output);
117
118	my @expected = (
119	't/source_tests/harness....',
120	'1..1',
121	'[[reset]]',
122	'ok 1 - this is a test',
123	'[[reset]]',
124	'ok',
125	'All tests successful.',
126	);
127	my $status = pop @output;
128	my $expected_status = qr{^Result: PASS$};
129	my $summary = pop @output;
130	my $expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs};
131
132	is_deeply \@output, \@expected, '... and the output should be correct';
133	like $status, $expected_status,
134	'... and the status line should be correct';
135	like $summary, $expected_summary,
136	'... and the report summary should look correct';
137
138	# use an alias for test name
139
140	@output = ();
141	ok $aggregate
142	= _runtests( $harness, [ 't/source_tests/harness', 'My Nice Test' ] ),
143	'... runtests returns the aggregate';
144
145	isa_ok $aggregate, 'TAP::Parser::Aggregator';
146
147	chomp(@output);
148
149	@expected = (
150	'My Nice Test....',
151	'1..1',
152	'[[reset]]',
153	'ok 1 - this is a test',
154	'[[reset]]',
155	'ok',
156	'All tests successful.',
157	);
158	$status = pop @output;
159	$expected_status = qr{^Result: PASS$};
160	$summary = pop @output;
161	$expected_summary = qr{^Files=1, Tests=1, \d+ wallclock secs};
162
163	is_deeply \@output, \@expected, '... and the output should be correct';
164	like $status, $expected_status,
165	'... and the status line should be correct';
166	like $summary, $expected_summary,
167	'... and the report summary should look correct';
168
169	# run same test twice
170
171	@output = ();
172	ok $aggregate
173	= _runtests( $harness, [ 't/source_tests/harness', 'My Nice Test' ],
174	[ 't/source_tests/harness', 'My Nice Test Again' ] ),
175	'... runtests returns the aggregate';
176
177	isa_ok $aggregate, 'TAP::Parser::Aggregator';
178
179	chomp(@output);
180
181	@expected = (
182	'My Nice Test..........',
183	'1..1',
184	'[[reset]]',
185	'ok 1 - this is a test',
186	'[[reset]]',
187	'ok',
188	'My Nice Test Again....',
189	'1..1',
190	'[[reset]]',
191	'ok 1 - this is a test',
192	'[[reset]]',
193	'ok',
194	'All tests successful.',
195	);
196	$status = pop @output;
197	$expected_status = qr{^Result: PASS$};
198	$summary = pop @output;
199	$expected_summary = qr{^Files=2, Tests=2, \d+ wallclock secs};
200
201	is_deeply \@output, \@expected, '... and the output should be correct';
202	like $status, $expected_status,
203	'... and the status line should be correct';
204	like $summary, $expected_summary,
205	'... and the report summary should look correct';
206
207	# normal tests in quiet mode
208
209	@output = ();
210	_runtests( $harness_whisper, 't/source_tests/harness' );
211
212	chomp(@output);
213	@expected = (
214	't/source_tests/harness....',
215	'ok',
216	'All tests successful.',
217	);
218
219	$status = pop @output;
220	$expected_status = qr{^Result: PASS$};
221	$summary = pop @output;
222	$expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/;
223
224	is_deeply \@output, \@expected, '... and the output should be correct';
225	like $status, $expected_status,
226	'... and the status line should be correct';
227	like $summary, $expected_summary,
228	'... and the report summary should look correct';
229
230	# normal tests in really_quiet mode
231
232	@output = ();
233	_runtests( $harness_mute, 't/source_tests/harness' );
234
235	chomp(@output);
236	@expected = (
237	'All tests successful.',
238	);
239
240	$status = pop @output;
241	$expected_status = qr{^Result: PASS$};
242	$summary = pop @output;
243	$expected_summary = qr/^Files=1, Tests=1, \d+ wallclock secs/;
244
245	is_deeply \@output, \@expected, '... and the output should be correct';
246	like $status, $expected_status,
247	'... and the status line should be correct';
248	like $summary, $expected_summary,
249	'... and the report summary should look correct';
250
251	# normal tests with failures
252
253	@output = ();
254	_runtests( $harness, 't/source_tests/harness_failure' );
255
256	$status = pop @output;
257	$summary = pop @output;
258
259	like $status, qr{^Result: FAIL$},
260	'... and the status line should be correct';
261
262	my @summary = @output[ 10 .. $#output ];
263	@output = @output[ 0 .. 9 ];
264
265	@expected = (
266	't/source_tests/harness_failure....',
267	'1..2',
268	'[[reset]]',
269	'ok 1 - this is a test',
270	'[[reset]]',
271	'[[red]]',
272	'not ok 2 - this is another test',
273	'[[reset]]',
274	'[[red]]',
275	'Failed 1/2 subtests',
276	);
277
278	is_deeply \@output, \@expected,
279	'... and failing test output should be correct';
280
281	my @expected_summary = (
282	'[[reset]]',
283	'Test Summary Report',
284	'-------------------',
285	'[[red]]',
286	't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)',
287	'[[reset]]',
288	'[[red]]',
69f36734	289	'Failed test:',
b965d173	290	'[[reset]]',
	291	'[[red]]',
	292	'2',
	293	'[[reset]]',
	294	);
	295
	296	is_deeply \@summary, \@expected_summary,
	297	'... and the failure summary should also be correct';
	298
	299	# quiet tests with failures
	300
	301	@output = ();
	302	_runtests( $harness_whisper, 't/source_tests/harness_failure' );
	303
	304	$status = pop @output;
	305	$summary = pop @output;
	306	@expected = (
	307	't/source_tests/harness_failure....',
	308	'Failed 1/2 subtests',
	309	'Test Summary Report',
	310	'-------------------',
	311	't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)',
69f36734	312	'Failed test:',
b965d173	313	'2',
	314	);
	315
	316	like $status, qr{^Result: FAIL$},
	317	'... and the status line should be correct';
	318
	319	is_deeply \@output, \@expected,
	320	'... and failing test output should be correct';
	321
	322	# really quiet tests with failures
	323
	324	@output = ();
	325	_runtests( $harness_mute, 't/source_tests/harness_failure' );
	326
	327	$status = pop @output;
	328	$summary = pop @output;
	329	@expected = (
	330	'Test Summary Report',
	331	'-------------------',
	332	't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)',
69f36734	333	'Failed test:',
b965d173	334	'2',
	335	);
	336
	337	like $status, qr{^Result: FAIL$},
	338	'... and the status line should be correct';
	339
	340	is_deeply \@output, \@expected,
	341	'... and failing test output should be correct';
	342
	343	# only show directives
	344
	345	@output = ();
	346	_runtests(
	347	$harness_directives,
	348	't/source_tests/harness_directives'
	349	);
	350
	351	chomp(@output);
	352
	353	@expected = (
	354	't/source_tests/harness_directives....',
	355	'not ok 2 - we have a something # TODO some output',
	356	"ok 3 houston, we don't have liftoff # SKIP no funding",
	357	'ok',
	358	'All tests successful.',
	359
	360	# ~TODO {{{ this should be an option
	361	#'Test Summary Report',
	362	#'-------------------',
	363	#'t/source_tests/harness_directives (Wstat: 0 Tests: 3 Failed: 0)',
	364	#'Tests skipped:',
	365	#'3',
	366	# }}}
	367	);
	368
	369	$status = pop @output;
	370	$summary = pop @output;
	371	$expected_summary = qr/^Files=1, Tests=3, \d+ wallclock secs/;
	372
	373	is_deeply \@output, \@expected, '... and the output should be correct';
	374	like $summary, $expected_summary,
	375	'... and the report summary should look correct';
	376
	377	like $status, qr{^Result: PASS$},
	378	'... and the status line should be correct';
	379
	380	# normal tests with bad tap
	381
	382	# install callback handler
	383	my $parser;
	384	my $callback_count = 0;
	385
	386	my @callback_log = ();
	387
	388	for my $evt (qw(parser_args made_parser before_runtests after_runtests)) {
	389	$harness->callback(
	390	$evt => sub {
	391	push @callback_log, $evt;
	392	}
	393	);
	394	}
	395
	396	$harness->callback(
	397	made_parser => sub {
398	$parser = shift;
399	$callback_count++;
400	}
401	);
402
403	@output = ();
404	_runtests( $harness, 't/source_tests/harness_badtap' );
405	chomp(@output);
406
407	@output = map { trim($_) } @output;
408	$status = pop @output;
409	@summary = @output[ 12 .. ( $#output - 1 ) ];
410	@output = @output[ 0 .. 11 ];
411	@expected = (
412	't/source_tests/harness_badtap....',
413	'1..2',
414	'[[reset]]',
415	'ok 1 - this is a test',
416	'[[reset]]',
417	'[[red]]',
418	'not ok 2 - this is another test',
419	'[[reset]]',
420	'1..2',
421	'[[reset]]',
422	'[[red]]',
423	'Failed 1/2 subtests',
424	);
425	is_deeply \@output, \@expected,
426	'... and failing test output should be correct';
427	like $status, qr{^Result: FAIL$},
428	'... and the status line should be correct';
429	@expected_summary = (
430	'[[reset]]',
431	'Test Summary Report',
432	'-------------------',
433	'[[red]]',
434	't/source_tests/harness_badtap (Wstat: 0 Tests: 2 Failed: 1)',
435	'[[reset]]',
436	'[[red]]',
69f36734	437	'Failed test:',
b965d173	438	'[[reset]]',
	439	'[[red]]',
	440	'2',
	441	'[[reset]]',
	442	'[[red]]',
	443	'Parse errors: More than one plan found in TAP output',
	444	'[[reset]]',
	445	);
	446	is_deeply \@summary, \@expected_summary,
	447	'... and the badtap summary should also be correct';
	448
	449	cmp_ok( $callback_count, '==', 1, 'callback called once' );
	450	is_deeply(
	451	\@callback_log,
	452	[ 'before_runtests', 'parser_args', 'made_parser', 'after_runtests' ],
	453	'callback log matches'
	454	);
	455	isa_ok $parser, 'TAP::Parser';
	456
	457	# coverage testing for _should_show_failures
	458	# only show failures
	459
	460	@output = ();
	461	_runtests( $harness_failures, 't/source_tests/harness_failure' );
	462
	463	chomp(@output);
	464
	465	@expected = (
	466	't/source_tests/harness_failure....',
	467	'not ok 2 - this is another test',
	468	'Failed 1/2 subtests',
	469	'Test Summary Report',
	470	'-------------------',
	471	't/source_tests/harness_failure (Wstat: 0 Tests: 2 Failed: 1)',
69f36734	472	'Failed test:',
b965d173	473	'2',
	474	);
	475
	476	$status = pop @output;
	477	$summary = pop @output;
	478
	479	like $status, qr{^Result: FAIL$},
	480	'... and the status line should be correct';
	481	$expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/;
	482	is_deeply \@output, \@expected, '... and the output should be correct';
	483
	484	# check the status output for no tests
	485
	486	@output = ();
	487	_runtests( $harness_failures, 't/sample-tests/no_output' );
	488
	489	chomp(@output);
	490
	491	@expected = (
	492	't/sample-tests/no_output....',
	493	'No subtests run',
	494	'Test Summary Report',
	495	'-------------------',
	496	't/sample-tests/no_output (Wstat: 0 Tests: 0 Failed: 0)',
	497	'Parse errors: No plan found in TAP output',
	498	);
	499
	500	$status = pop @output;
	501	$summary = pop @output;
	502
	503	like $status, qr{^Result: FAIL$},
	504	'... and the status line should be correct';
	505	$expected_summary = qr/^Files=1, Tests=2, \d+ wallclock secs/;
	506	is_deeply \@output, \@expected, '... and the output should be correct';
	507
	508	#XXXX
	509	}
	510
	511	# make sure we can exec something ... anything!
	512	SKIP: {
	513
	514	my $cat = '/bin/cat';
	515	unless ( -e $cat ) {
	516	skip "no '$cat'", 2;
	517	}
	518
	519	my $capture = IO::c55Capture->new_handle;
	520	my $harness = TAP::Harness->new(
	521	{ verbosity => -2,
	522	stdout => $capture,
	523	exec => [$cat],
	524	}
	525	);
	526
	527	eval { _runtests( $harness, 't/data/catme.1' ) };
	528
	529	my @output = tied($$capture)->dump;
	530	my $status = pop @output;
	531	like $status, qr{^Result: PASS$},
	532	'... and the status line should be correct';
	533	pop @output; # get rid of summary line
	534	my $answer = pop @output;
	535	is( $answer, "All tests successful.\n", 'cat meows' );
	536	}
537
538	# catches "exec accumulates arguments" issue (r77)
539	{
540	my $capture = IO::c55Capture->new_handle;
541	my $harness = TAP::Harness->new(
542	{ verbosity => -2,
543	stdout => $capture,
544	exec => [$^X]
545	}
546	);
547
548	_runtests(
549	$harness,
550	't/source_tests/harness_complain'
551	, # will get mad if run with args
552	't/source_tests/harness',
553	);
554
555	my @output = tied($$capture)->dump;
556	my $status = pop @output;
557	like $status, qr{^Result: PASS$},
558	'... and the status line should be correct';
559	pop @output; # get rid of summary line
560	is( $output[-1], "All tests successful.\n",
561	'No exec accumulation'
562	);
563	}
564
565	sub trim {
566	$_[0] =~ s/^\s+\|\s+$//g;
567	return $_[0];
568	}
569
570	sub liblist {
571	return [ map {"-I$_"} @_ ];
3c87ea76	572	}
3c87ea76	573
b965d173	574	sub get_arg_sets {
	575
	576	# keys are keys to new()
	577	return {
	578	lib => {
	579	in => 'lib',
	580	out => liblist('lib'),
	581	test_name => '... a single lib switch should be correct'
	582	},
	583	verbosity => {
	584	in => 1,
	585	out => 1,
	586	test_name => '... and we should be able to set verbosity to 1'
	587	},
	588
	589	# verbose => {
	590	# in => 1,
	591	# out => 1,
	592	# test_name => '... and we should be able to set verbose to true'
	593	# },
	594	},
	595	{ lib => {
	596	in => [ 'lib', 't' ],
	597	out => liblist( 'lib', 't' ),
	598	test_name => '... multiple lib dirs should be correct'
	599	},
	600	verbosity => {
	601	in => 0,
	602	out => 0,
	603	test_name => '... and we should be able to set verbosity to 0'
	604	},
	605
	606	# verbose => {
	607	# in => 0,
	608	# out => 0,
	609	# test_name => '... and we should be able to set verbose to false'
	610	# },
	611	},
	612	{ switches => {
	613	in => [ '-T', '-w', '-T' ],
	614	out => [ '-T', '-w', '-T' ],
	615	test_name => '... duplicate switches should remain',
	616	},
	617	failures => {
	618	in => 1,
	619	out => 1,
	620	test_name =>
	621	'... and we should be able to set failures to true',
	622	},
	623	verbosity => {
	624	in => -1,
	625	out => -1,
	626	test_name => '... and we should be able to set verbosity to -1'
	627	},
	628
	629	# quiet => {
	630	# in => 1,
	631	# out => 1,
	632	# test_name => '... and we should be able to set quiet to false'
	633	# },
	634	},
	635
	636	{ verbosity => {
	637	in => -2,
638	out => -2,
639	test_name => '... and we should be able to set verbosity to -2'
640	},
641
642	# really_quiet => {
643	# in => 1,
644	# out => 1,
645	# test_name =>
646	# '... and we should be able to set really_quiet to true',
647	# },
648	exec => {
649	in => $^X,
650	out => $^X,
651	test_name =>
652	'... and we should be able to set the executable',
653	},
654	},
655	{ switches => {
656	in => 'T',
657	out => ['T'],
658	test_name =>
659	'... leading dashes (-) on switches are not optional',
660	},
661	},
662	{ switches => {
663	in => '-T',
664	out => ['-T'],
665	test_name => '... we should be able to set switches',
666	},
667	failures => {
668	in => 1,
669	out => 1,
670	test_name => '... and we should be able to set failures to true'
671	},
672	};
673	}
674
675	sub _runtests {
676	my ( $harness, @tests ) = @_;
677	local $ENV{PERL_TEST_HARNESS_DUMP_TAP} = 0;
678	my $aggregate = $harness->runtests(@tests);
679	return $aggregate;
680	}
681
682	{
683
684	# coverage tests for ctor
685
686	my $harness = TAP::Harness->new(
687	{ timer => 0,
688	errors => 1,
689	merge => 2,
690
691	# formatter => 3,
692	}
693	);
694
695	is $harness->timer(), 0, 'timer getter';
696	is $harness->timer(10), 10, 'timer setter';
697	is $harness->errors(), 1, 'errors getter';
698	is $harness->errors(10), 10, 'errors setter';
699	is $harness->merge(), 2, 'merge getter';
700	is $harness->merge(10), 10, 'merge setter';
701
702	# jobs accessor
703	is $harness->jobs(), 1, 'jobs';
704	}
705
706	{
707
708	# coverage tests for the stdout key of VALIDATON_FOR, used by _initialize() in the ctor
709
710	# the coverage tests are
711	# 1. ref $ref => false
712	# 2. ref => ! GLOB and ref->can(print)
713	# 3. ref $ref => GLOB
714
715	# case 1
716
717	my @die;
718
719	eval {
720	local $SIG{__DIE__} = sub { push @die, @_ };
721
722	my $harness = TAP::Harness->new(
723	{ stdout => bless {}, '0', # how evil is THAT !!!
724	}
725	);
726	};
727
728	is @die, 1, 'bad filehandle to stdout';
729	like pop @die, qr/option 'stdout' needs a filehandle/,
730	'... and we died as expected';
731
732	# case 2
733
734	@die = ();
735
736	package Printable;
737
738	sub new { return bless {}, shift }
739
740	sub print {return}
741
742	package main;
743
744	my $harness = TAP::Harness->new(
745	{ stdout => Printable->new(),
746	}
747	);
748
749	isa_ok $harness, 'TAP::Harness';
750
751	# case 3
752
753	@die = ();
754
755	$harness = TAP::Harness->new(
756	{ stdout => bless {}, 'GLOB', # again with the evil
757	}
758	);
759
760	isa_ok $harness, 'TAP::Harness';
761	}
762
763	{
764
765	# coverage testing of lib/switches accessor
766	my $harness = TAP::Harness->new;
767
768	my @die;
769
770	eval {
771	local $SIG{__DIE__} = sub { push @die, @_ };
772
773	$harness->switches(qw( too many arguments));
774	};
775
776	is @die, 1, 'too many arguments to accessor';
777
778	like pop @die, qr/Too many arguments to method 'switches'/,
779	'...and we died as expected';
780
781	$harness->switches('simple scalar');
782
783	my $arrref = $harness->switches;
784	is_deeply $arrref, ['simple scalar'], 'scalar wrapped in arr ref';
785	}
786
787	{
788
789	# coverage tests for the basically untested T::H::_open_spool
790
791	$ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(qw(t spool));
792
793	# now given that we're going to be writing stuff to the file system, make sure we have
794	# a cleanup hook
795
796	END {
797	use File::Path;
798
799	# remove the tree if we made it this far
800	rmtree( $ENV{PERL_TEST_HARNESS_DUMP_TAP} )
801	if $ENV{PERL_TEST_HARNESS_DUMP_TAP};
802	}
803
804	my $harness = TAP::Harness->new( { verbosity => -2 } );
805
806	can_ok $harness, 'runtests';
807
808	# normal tests in verbose mode
809
810	my $parser = $harness->runtests(
811	File::Spec->catfile(qw (t source_tests harness )) );
812
813	isa_ok $parser, 'TAP::Parser::Aggregator',
814	'... runtests returns the aggregate';
815
816	ok -e File::Spec->catfile(
817	$ENV{PERL_TEST_HARNESS_DUMP_TAP},
818	qw( t source_tests harness )
819	);
820	}