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