vcs.maemo.org Git - pkg-perl/blob - deb-src/libtest-harness-perl/libtest-harness-perl-3.12/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     package MyResult;
  63     use strict;
  64     use vars qw($VERSION @ISA);
  65     @ISA = 'TAP::Parser::Result';
  66     TAP::Parser::ResultFactory->register_type( 'my_type' => __PACKAGE__ );
  67 }
  68
  69 {
  70     my $r = eval { $factory->make_result( { type => 'my_type' } ) };
  71     my $error = $@;
  72     isa_ok( $r, 'MyResult', 'register custom type' );
  73     ok( !$error, '... and no error' );
  74 }
  75
  76 #
  77 # test unknown tokens
  78 #
  79
  80 run_tests(
  81     {   class => UNKNOWN,
  82         data  => {
  83             type => 'unknown',
  84             raw  => '... this line is junk ... ',
  85         },
  86     },
  87     {   is_unknown    => 1,
  88         raw           => '... this line is junk ... ',
  89         as_string     => '... this line is junk ... ',
  90         type          => 'unknown',
  91         has_directive => '',
  92     }
  93 );
  94
  95 #
  96 # test comment tokens
  97 #
  98
  99 run_tests(
 100     {   class => COMMENT,
 101         data  => {
 102             type    => 'comment',
 103             raw     => '#   this is a comment',
 104             comment => 'this is a comment',
 105         },
 106     },
 107     {   is_comment    => 1,
 108         raw           => '#   this is a comment',
 109         as_string     => '#   this is a comment',
 110         comment       => 'this is a comment',
 111         type          => 'comment',
 112         has_directive => '',
 113     }
 114 );
 115
 116 #
 117 # test bailout tokens
 118 #
 119
 120 run_tests(
 121     {   class => BAILOUT,
 122         data  => {
 123             type    => 'bailout',
 124             raw     => 'Bailout!  This blows!',
 125             bailout => 'This blows!',
 126         },
 127     },
 128     {   is_bailout    => 1,
 129         raw           => 'Bailout!  This blows!',
 130         as_string     => 'This blows!',
 131         type          => 'bailout',
 132         has_directive => '',
 133     }
 134 );
 135
 136 #
 137 # test plan tokens
 138 #
 139
 140 run_tests(
 141     {   class => PLAN,
 142         data  => {
 143             type          => 'plan',
 144             raw           => '1..20',
 145             tests_planned => 20,
 146             directive     => '',
 147             explanation   => '',
 148         },
 149     },
 150     {   is_plan       => 1,
 151         raw           => '1..20',
 152         tests_planned => 20,
 153         directive     => '',
 154         explanation   => '',
 155         has_directive => '',
 156     }
 157 );
 158
 159 run_tests(
 160     {   class => PLAN,
 161         data  => {
 162             type          => 'plan',
 163             raw           => '1..0 # SKIP help me, Rhonda!',
 164             tests_planned => 0,
 165             directive     => 'SKIP',
 166             explanation   => 'help me, Rhonda!',
 167         },
 168     },
 169     {   is_plan       => 1,
 170         raw           => '1..0 # SKIP help me, Rhonda!',
 171         tests_planned => 0,
 172         directive     => 'SKIP',
 173         explanation   => 'help me, Rhonda!',
 174         has_directive => 1,
 175     }
 176 );
 177
 178 #
 179 # test 'test' tokens
 180 #
 181
 182 my $test = run_tests(
 183     {   class => TEST,
 184         data  => {
 185             ok          => 'ok',
 186             test_num    => 5,
 187             description => '... and this test is fine',
 188             directive   => '',
 189             explanation => '',
 190             raw         => 'ok 5 and this test is fine',
 191             type        => 'test',
 192         },
 193     },
 194     {   is_test       => 1,
 195         type          => 'test',
 196         ok            => 'ok',
 197         number        => 5,
 198         description   => '... and this test is fine',
 199         directive     => '',
 200         explanation   => '',
 201         is_ok         => 1,
 202         is_actual_ok  => 1,
 203         todo_passed   => '',
 204         has_skip      => '',
 205         has_todo      => '',
 206         as_string     => 'ok 5 ... and this test is fine',
 207         is_unplanned  => '',
 208         has_directive => '',
 209     }
 210 );
 211
 212 can_ok $test, 'actual_passed';
 213 $warning = '';
 214 is $test->actual_passed, $test->is_actual_ok,
 215   '... and it should return the correct value';
 216 like $warning,
 217   qr/^\Qactual_passed() is deprecated.  Please use "is_actual_ok()"/,
 218   '... but issue a deprecation warning';
 219
 220 can_ok $test, 'todo_failed';
 221 $warning = '';
 222 is $test->todo_failed, $test->todo_passed,
 223   '... and it should return the correct value';
 224 like $warning,
 225   qr/^\Qtodo_failed() is deprecated.  Please use "todo_passed()"/,
 226   '... but issue a deprecation warning';
 227
 228 # TODO directive
 229
 230 $test = run_tests(
 231     {   class => TEST,
 232         data  => {
 233             ok          => 'not ok',
 234             test_num    => 5,
 235             description => '... and this test is fine',
 236             directive   => 'TODO',
 237             explanation => 'why not?',
 238             raw         => 'not ok 5 and this test is fine # TODO why not?',
 239             type        => 'test',
 240         },
 241     },
 242     {   is_test      => 1,
 243         type         => 'test',
 244         ok           => 'not ok',
 245         number       => 5,
 246         description  => '... and this test is fine',
 247         directive    => 'TODO',
 248         explanation  => 'why not?',
 249         is_ok        => 1,
 250         is_actual_ok => '',
 251         todo_passed  => '',
 252         has_skip     => '',
 253         has_todo     => 1,
 254         as_string =>
 255           'not ok 5 ... and this test is fine # TODO why not?',
 256         is_unplanned  => '',
 257         has_directive => 1,
 258     }
 259 );
 260
 261 sub run_tests {
 262     my ( $instantiated, $value_for ) = @_;
 263     my $result = instantiate($instantiated);
 264     run_method_tests( $result, $value_for );
 265     return $result;
 266 }
 267
 268 sub instantiate {
 269     my $instantiated = shift;
 270     my $class        = $instantiated->{class};
 271     ok my $result = $factory->make_result( $instantiated->{data} ),
 272       'Creating $class results should succeed';
 273     isa_ok $result, $class, '.. and the object it returns';
 274     return $result;
 275 }
 276
 277 sub run_method_tests {
 278     my ( $result, $value_for ) = @_;
 279     while ( my ( $method, $default ) = each %inherited_methods ) {
 280         can_ok $result, $method;
 281         if ( defined( my $value = delete $value_for->{$method} ) ) {
 282             is $result->$method(), $value,
 283               "... and $method should be correct";
 284         }
 285         else {
 286             is $result->$method(), $default,
 287               "... and $method default should be correct";
 288         }
 289     }
 290     while ( my ( $method, $value ) = each %$value_for ) {
 291         can_ok $result, $method;
 292         is $result->$method(), $value, "... and $method should be correct";
 293     }
 294 }