Commit | Line | Data |
b965d173 |
1 | #!/usr/bin/perl -wT |
2 | |
3 | use strict; |
4 | use lib 't/lib'; |
5 | |
f7c69158 |
6 | use Test::More tests => 227; |
b965d173 |
7 | |
f7c69158 |
8 | use TAP::Parser::ResultFactory; |
b965d173 |
9 | use TAP::Parser::Result; |
10 | |
11 | use constant RESULT => 'TAP::Parser::Result'; |
12 | use constant PLAN => 'TAP::Parser::Result::Plan'; |
13 | use constant TEST => 'TAP::Parser::Result::Test'; |
14 | use constant COMMENT => 'TAP::Parser::Result::Comment'; |
15 | use constant BAILOUT => 'TAP::Parser::Result::Bailout'; |
16 | use constant UNKNOWN => 'TAP::Parser::Result::Unknown'; |
17 | |
18 | my $warning; |
19 | $SIG{__WARN__} = sub { $warning = shift }; |
20 | |
21 | # |
22 | # Note that the are basic unit tests. More comprehensive path coverage is |
23 | # found in the regression tests. |
24 | # |
25 | |
f7c69158 |
26 | my $factory = TAP::Parser::ResultFactory->new; |
b965d173 |
27 | my %inherited_methods = ( |
28 | is_plan => '', |
29 | is_test => '', |
30 | is_comment => '', |
31 | is_bailout => '', |
32 | is_unknown => '', |
33 | is_ok => 1, |
34 | ); |
35 | |
36 | my $abstract_class = bless { type => 'no_such_type' }, |
37 | RESULT; # you didn't see this |
38 | run_method_tests( $abstract_class, {} ); # check the defaults |
39 | |
40 | can_ok $abstract_class, 'type'; |
41 | is $abstract_class->type, 'no_such_type', |
42 | '... and &type should return the correct result'; |
43 | |
44 | can_ok $abstract_class, 'passed'; |
45 | $warning = ''; |
46 | ok $abstract_class->passed, '... and it should default to true'; |
47 | like $warning, qr/^\Qpassed() is deprecated. Please use "is_ok()"/, |
48 | '... but it should emit a deprecation warning'; |
49 | |
50 | can_ok RESULT, 'new'; |
f7c69158 |
51 | |
52 | can_ok $factory, 'make_result'; |
53 | eval { $factory->make_result( { type => 'no_such_type' } ) }; |
b965d173 |
54 | ok my $error = $@, '... and calling it with an unknown class should fail'; |
55 | like $error, qr/^Could not determine class for.*no_such_type/s, |
56 | '... with an appropriate error message'; |
57 | |
f7c69158 |
58 | # register new Result types: |
59 | can_ok $factory, 'class_for'; |
60 | can_ok $factory, 'register_type'; |
61 | { |
62 | |
63 | package MyResult; |
64 | use strict; |
65 | use vars qw($VERSION @ISA); |
66 | @ISA = 'TAP::Parser::Result'; |
67 | TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ ); |
68 | } |
69 | |
70 | { |
71 | my $r = eval { $factory->make_result( { type => 'my_type' } ) }; |
72 | my $error = $@; |
73 | isa_ok( $r, 'MyResult', 'register custom type' ); |
74 | ok( !$error, '... and no error' ); |
75 | } |
76 | |
b965d173 |
77 | # |
78 | # test unknown tokens |
79 | # |
80 | |
81 | run_tests( |
82 | { class => UNKNOWN, |
83 | data => { |
84 | type => 'unknown', |
85 | raw => '... this line is junk ... ', |
86 | }, |
87 | }, |
88 | { is_unknown => 1, |
89 | raw => '... this line is junk ... ', |
90 | as_string => '... this line is junk ... ', |
91 | type => 'unknown', |
92 | has_directive => '', |
93 | } |
94 | ); |
95 | |
96 | # |
97 | # test comment tokens |
98 | # |
99 | |
100 | run_tests( |
101 | { class => COMMENT, |
102 | data => { |
103 | type => 'comment', |
104 | raw => '# this is a comment', |
105 | comment => 'this is a comment', |
106 | }, |
107 | }, |
108 | { is_comment => 1, |
109 | raw => '# this is a comment', |
110 | as_string => '# this is a comment', |
111 | comment => 'this is a comment', |
112 | type => 'comment', |
113 | has_directive => '', |
114 | } |
115 | ); |
116 | |
117 | # |
118 | # test bailout tokens |
119 | # |
120 | |
121 | run_tests( |
122 | { class => BAILOUT, |
123 | data => { |
124 | type => 'bailout', |
125 | raw => 'Bailout! This blows!', |
126 | bailout => 'This blows!', |
127 | }, |
128 | }, |
129 | { is_bailout => 1, |
130 | raw => 'Bailout! This blows!', |
131 | as_string => 'This blows!', |
132 | type => 'bailout', |
133 | has_directive => '', |
134 | } |
135 | ); |
136 | |
137 | # |
138 | # test plan tokens |
139 | # |
140 | |
141 | run_tests( |
142 | { class => PLAN, |
143 | data => { |
144 | type => 'plan', |
145 | raw => '1..20', |
146 | tests_planned => 20, |
147 | directive => '', |
148 | explanation => '', |
149 | }, |
150 | }, |
151 | { is_plan => 1, |
152 | raw => '1..20', |
153 | tests_planned => 20, |
154 | directive => '', |
155 | explanation => '', |
156 | has_directive => '', |
157 | } |
158 | ); |
159 | |
160 | run_tests( |
161 | { class => PLAN, |
162 | data => { |
163 | type => 'plan', |
164 | raw => '1..0 # SKIP help me, Rhonda!', |
165 | tests_planned => 0, |
166 | directive => 'SKIP', |
167 | explanation => 'help me, Rhonda!', |
168 | }, |
169 | }, |
170 | { is_plan => 1, |
171 | raw => '1..0 # SKIP help me, Rhonda!', |
172 | tests_planned => 0, |
173 | directive => 'SKIP', |
174 | explanation => 'help me, Rhonda!', |
175 | has_directive => 1, |
176 | } |
177 | ); |
178 | |
179 | # |
180 | # test 'test' tokens |
181 | # |
182 | |
183 | my $test = run_tests( |
184 | { class => TEST, |
185 | data => { |
186 | ok => 'ok', |
187 | test_num => 5, |
188 | description => '... and this test is fine', |
189 | directive => '', |
190 | explanation => '', |
191 | raw => 'ok 5 and this test is fine', |
192 | type => 'test', |
193 | }, |
194 | }, |
195 | { is_test => 1, |
196 | type => 'test', |
197 | ok => 'ok', |
198 | number => 5, |
199 | description => '... and this test is fine', |
200 | directive => '', |
201 | explanation => '', |
202 | is_ok => 1, |
203 | is_actual_ok => 1, |
204 | todo_passed => '', |
205 | has_skip => '', |
206 | has_todo => '', |
207 | as_string => 'ok 5 ... and this test is fine', |
208 | is_unplanned => '', |
209 | has_directive => '', |
210 | } |
211 | ); |
212 | |
213 | can_ok $test, 'actual_passed'; |
214 | $warning = ''; |
215 | is $test->actual_passed, $test->is_actual_ok, |
216 | '... and it should return the correct value'; |
217 | like $warning, |
218 | qr/^\Qactual_passed() is deprecated. Please use "is_actual_ok()"/, |
219 | '... but issue a deprecation warning'; |
220 | |
221 | can_ok $test, 'todo_failed'; |
222 | $warning = ''; |
223 | is $test->todo_failed, $test->todo_passed, |
224 | '... and it should return the correct value'; |
225 | like $warning, |
226 | qr/^\Qtodo_failed() is deprecated. Please use "todo_passed()"/, |
227 | '... but issue a deprecation warning'; |
228 | |
229 | # TODO directive |
230 | |
231 | $test = run_tests( |
232 | { class => TEST, |
233 | data => { |
234 | ok => 'not ok', |
235 | test_num => 5, |
236 | description => '... and this test is fine', |
237 | directive => 'TODO', |
238 | explanation => 'why not?', |
239 | raw => 'not ok 5 and this test is fine # TODO why not?', |
240 | type => 'test', |
241 | }, |
242 | }, |
243 | { is_test => 1, |
244 | type => 'test', |
245 | ok => 'not ok', |
246 | number => 5, |
247 | description => '... and this test is fine', |
248 | directive => 'TODO', |
249 | explanation => 'why not?', |
250 | is_ok => 1, |
251 | is_actual_ok => '', |
252 | todo_passed => '', |
253 | has_skip => '', |
254 | has_todo => 1, |
255 | as_string => |
256 | 'not ok 5 ... and this test is fine # TODO why not?', |
257 | is_unplanned => '', |
258 | has_directive => 1, |
259 | } |
260 | ); |
261 | |
262 | sub run_tests { |
263 | my ( $instantiated, $value_for ) = @_; |
264 | my $result = instantiate($instantiated); |
265 | run_method_tests( $result, $value_for ); |
266 | return $result; |
267 | } |
268 | |
269 | sub instantiate { |
270 | my $instantiated = shift; |
271 | my $class = $instantiated->{class}; |
f7c69158 |
272 | ok my $result = $factory->make_result( $instantiated->{data} ), |
b965d173 |
273 | 'Creating $class results should succeed'; |
274 | isa_ok $result, $class, '.. and the object it returns'; |
275 | return $result; |
276 | } |
277 | |
278 | sub run_method_tests { |
279 | my ( $result, $value_for ) = @_; |
280 | while ( my ( $method, $default ) = each %inherited_methods ) { |
281 | can_ok $result, $method; |
282 | if ( defined( my $value = delete $value_for->{$method} ) ) { |
283 | is $result->$method(), $value, |
284 | "... and $method should be correct"; |
285 | } |
286 | else { |
287 | is $result->$method(), $default, |
288 | "... and $method default should be correct"; |
289 | } |
290 | } |
291 | while ( my ( $method, $value ) = each %$value_for ) { |
292 | can_ok $result, $method; |
293 | is $result->$method(), $value, "... and $method should be correct"; |
294 | } |
295 | } |