Upgrade to Test::Harness 3.14

[p5sagit/p5-mst-13.2.git] / ext / Test / Harness / t / proverun.t

#!/usr/bin/perl -w

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

use strict;
use Test::More;
use File::Spec;
use App::Prove;

my @SCHEDULE;

BEGIN {

    # to add a new test to proverun, just list the name of the file in
    # t/sample-tests and a name for the test.  The rest is handled
    # automatically.
    my @tests = (
        {   file => 'simple',
            name => 'Create empty',
        },
        {   file => 'todo_inline',
            name => 'Passing TODO',
        },
    );
    foreach my $test (@tests) {
        
        # let's fully expand that filename
        $test->{file} = File::Spec->catfile(
            (   $ENV{PERL_CORE}
                ? ( File::Spec->updir(), 'ext', 'Test', 'Harness' )
                : ()
            ),
            't',
            'sample-tests',
            $test->{file}
        );
    }
    @SCHEDULE = (
        map {
            {   name   => $_->{name},
                args   => [ $_->{file} ],
                expect => [
                    [   'new',
                        'TAP::Parser::Iterator::Process',
                        {   merge   => undef,
                            command => [
                                'PERL',
                                $_->{file},
                            ],
                            setup    => \'CODE',
                            teardown => \'CODE',

                        }
                    ]
                ]
            }
          } @tests
    );

    plan tests => @SCHEDULE * 3;
}

# Waaaaay too much boilerplate

package FakeProve;
use vars qw( @ISA );

@ISA = qw( App::Prove );

sub new {
    my $class = shift;
    my $self  = $class->SUPER::new(@_);
    $self->{_log} = [];
    return $self;
}

sub get_log {
    my $self = shift;
    my @log  = @{ $self->{_log} };
    $self->{_log} = [];
    return @log;
}

package main;

{
    use TAP::Parser::Iterator::Process;
    use TAP::Formatter::Console;

    # Patch TAP::Parser::Iterator::Process
    my @call_log = ();

    local $^W;    # no warnings

    my $orig_new = TAP::Parser::Iterator::Process->can('new');

    # Avoid "used only once" warning
    *TAP::Parser::Iterator::Process::new
      = *TAP::Parser::Iterator::Process::new = sub {
        push @call_log, [ 'new', @_ ];

        # And then new turns round and tramples on our args...
        $_[1] = { %{ $_[1] } };
        $orig_new->(@_);
      };

    # Patch TAP::Formatter::Console;
    my $orig_output = \&TAP::Formatter::Console::_output;
    *TAP::Formatter::Console::_output = sub {

        # push @call_log, [ '_output', @_ ];
    };

    sub get_log {
        my @log = @call_log;
        @call_log = ();
        return @log;
    }
}

sub _slacken {
    my $obj = shift;
    if ( my $ref = ref $obj ) {
        if ( 'HASH' eq ref $obj ) {
            return { map { $_ => _slacken( $obj->{$_} ) } keys %$obj };
        }
        elsif ( 'ARRAY' eq ref $obj ) {
            return [ map { _slacken($_) } @$obj ];
        }
        elsif ( 'SCALAR' eq ref $obj ) {
            return $obj;
        }
        else {
            return \$ref;
        }
    }
    else {
        return $obj;
    }
}

sub is_slackly($$$) {
    my ( $got, $want, $msg ) = @_;
    return is_deeply _slacken($got), _slacken($want), $msg;
}

# ACTUAL TEST
for my $test (@SCHEDULE) {
    my $name = $test->{name};

    my $app = FakeProve->new;
    $app->process_args( '--norc', @{ $test->{args} } );

    # Why does this make the output from the test spew out of
    # our STDOUT?
    ok eval { $app->run }, 'run returned true';
    ok !$@, 'no errors' or diag $@;

    my @log = get_log();

    # Bodge: we don't know what pathname will be used for the exe so we
    # obliterate it here. Need to test that it's sane.
    for my $call (@log) {
        if ( 'HASH' eq ref $call->[2] && exists $call->[2]->{command} ) {
            $call->[2]->{command}->[0] = 'PERL';
        }
    }

    is_slackly \@log, $test->{expect}, "$name: command args OK";

    # use Data::Dumper;
    # diag Dumper(
    #     {   got    => \@log,
    #         expect => $test->{expect}
    #     }
    # );
}