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