1#!/usr/bin/perl -w
2
3BEGIN {
4    unshift @INC, 't/lib';
5}
6
7use strict;
8use warnings;
9use Test::More;
10use File::Spec;
11use App::Prove;
12use Text::ParseWords qw(shellwords);
13
14my @SCHEDULE;
15
16BEGIN {
17    my $t_dir = File::Spec->catdir('t');
18
19    # to add a new test to proverun, just list the name of the file in
20    # t/sample-tests and a name for the test.  The rest is handled
21    # automatically.
22    my @tests = (
23        {   file => 'simple',
24            name => 'Create empty',
25        },
26        {   file => 'todo_inline',
27            name => 'Passing TODO',
28        },
29    );
30
31    # TODO: refactor this and add in a test for:
32    # prove --source 'File: {extensions: [.1]}' t/source_tests/source.1
33
34    for my $test (@tests) {
35
36        # let's fully expand that filename
37        $test->{file}
38          = File::Spec->catfile( $t_dir, 'sample-tests', $test->{file} );
39    }
40    @SCHEDULE = (
41        map {
42            {   name   => $_->{name},
43                args   => [ $_->{file} ],
44                expect => [
45                    [   'new',
46                        'TAP::Parser::Iterator::Process',
47                        {   merge   => undef,
48                            command => [
49                                'PERL',
50                                $ENV{HARNESS_PERL_SWITCHES}
51                                ? shellwords( $ENV{HARNESS_PERL_SWITCHES} )
52                                : (),
53                                $_->{file},
54                            ],
55                            setup    => \'CODE',
56                            teardown => \'CODE',
57
58                        }
59                    ]
60                ]
61            }
62          } @tests,
63    );
64
65    plan tests => @SCHEDULE * 3;
66}
67
68# Waaaaay too much boilerplate
69
70package FakeProve;
71
72use base qw( App::Prove );
73
74sub new {
75    my $class = shift;
76    my $self  = $class->SUPER::new(@_);
77    $self->{_log} = [];
78    return $self;
79}
80
81sub get_log {
82    my $self = shift;
83    my @log  = @{ $self->{_log} };
84    $self->{_log} = [];
85    return @log;
86}
87
88package main;
89
90{
91    use TAP::Parser::Iterator::Process;
92    use TAP::Formatter::Console;
93
94    # Patch TAP::Parser::Iterator::Process
95    my @call_log = ();
96
97    no warnings qw(redefine once);
98
99    my $orig_new = TAP::Parser::Iterator::Process->can('new');
100
101    *TAP::Parser::Iterator::Process::new = sub {
102        push @call_log, [ 'new', @_ ];
103
104        # And then new turns round and tramples on our args...
105        $_[1] = { %{ $_[1] } };
106        $orig_new->(@_);
107      };
108
109    # Patch TAP::Formatter::Console;
110    my $orig_output = \&TAP::Formatter::Console::_output;
111    *TAP::Formatter::Console::_output = sub {
112
113        # push @call_log, [ '_output', @_ ];
114    };
115
116    sub get_log {
117        my @log = @call_log;
118        @call_log = ();
119        return @log;
120    }
121}
122
123sub _slacken {
124    my $obj = shift;
125    if ( my $ref = ref $obj ) {
126        if ( 'HASH' eq ref $obj ) {
127            return { map { $_ => _slacken( $obj->{$_} ) } keys %$obj };
128        }
129        elsif ( 'ARRAY' eq ref $obj ) {
130            return [ map { _slacken($_) } @$obj ];
131        }
132        elsif ( 'SCALAR' eq ref $obj ) {
133            return $obj;
134        }
135        else {
136            return \$ref;
137        }
138    }
139    else {
140        return $obj;
141    }
142}
143
144sub is_slackly($$$) {
145    my ( $got, $want, $msg ) = @_;
146    return is_deeply _slacken($got), _slacken($want), $msg;
147}
148
149# ACTUAL TEST
150for my $test (@SCHEDULE) {
151    my $name = $test->{name};
152
153    my $app = FakeProve->new;
154    $app->process_args( '--norc', @{ $test->{args} } );
155
156    # Why does this make the output from the test spew out of
157    # our STDOUT?
158    ok eval { $app->run }, 'run returned true';
159    ok !$@, 'no errors' or diag $@;
160
161    my @log = get_log();
162
163    # Bodge: we don't know what pathname will be used for the exe so we
164    # obliterate it here. Need to test that it's sane.
165    for my $call (@log) {
166        if ( 'HASH' eq ref $call->[2] && exists $call->[2]->{command} ) {
167            $call->[2]->{command}->[0] = 'PERL';
168        }
169    }
170
171    is_slackly \@log, $test->{expect}, "$name: command args OK";
172
173    # use Data::Dumper;
174    # diag Dumper(
175    #     {   got    => \@log,
176    #         expect => $test->{expect}
177    #     }
178    # );
179}
180
181