cpan/Test-Harness/t/results.t

   1 #!/usr/bin/perl -wT
   2
   3 use strict;
   4 use lib 't/lib';
   5
   6 use Test::More tests => 227;
   7
   8 use TAP::Parser::ResultFactory;
   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
  26 my $factory           = TAP::Parser::ResultFactory->new;
  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';
  51
  52 can_ok $factory, 'make_result';
  53 eval { $factory->make_result( { type => 'no_such_type' } ) };
  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
  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
  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};
 272     ok my $result = $factory->make_result( $instantiated->{data} ),
 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 }