lib/Test/Harness/t/strap.t

   1 #!/usr/bin/perl -Tw
   2
   3 BEGIN {
   4     if( $ENV{PERL_CORE} ) {
   5         chdir 't';
   6         @INC = ('../lib', 'lib');
   7     }
   8     else {
   9         unshift @INC, 't/lib';
  10     }
  11 }
  12
  13 use strict;
  14
  15 use Test::More tests => 170;
  16
  17 use_ok('Test::Harness::Straps');
  18
  19 my $strap = Test::Harness::Straps->new;
  20 isa_ok( $strap, 'Test::Harness::Straps', 'new()' );
  21
  22 ### Testing _is_comment()
  23
  24 my $comment;
  25 ok( !$strap->_is_comment("foo", \$comment), '_is_comment(), not a comment'  );
  26 ok( !defined $comment,                      '  no comment set'              );
  27
  28 ok( !$strap->_is_comment("f # oo", \$comment), '  not a comment with #'     );
  29 ok( !defined $comment,                         '  no comment set'           );
  30
  31 my %comments = (
  32                 "# stuff and things # and stuff"    =>
  33                                         ' stuff and things # and stuff',
  34                 "    # more things "                => ' more things ',
  35                 "#"                                 => '',
  36                );
  37
  38 while( my($line, $line_comment) = each %comments ) {
  39     my $strap = Test::Harness::Straps->new;
  40     isa_ok( $strap, 'Test::Harness::Straps' );
  41
  42     my $name = substr($line, 0, 20);
  43     ok( $strap->_is_comment($line, \$comment),        "  comment '$name'"   );
  44     is( $comment, $line_comment,                      '  right comment set' );
  45 }
  46
  47
  48
  49 ### Testing _is_header()
  50
  51 my @not_headers = (' 1..2',
  52                    '1..M',
  53                    '1..-1',
  54                    '2..2',
  55                    '1..a',
  56                    '',
  57                   );
  58
  59 foreach my $unheader (@not_headers) {
  60     my $strap = Test::Harness::Straps->new;
  61
  62     ok( !$strap->_is_header($unheader),
  63         "_is_header(), not a header '$unheader'" );
  64
  65     ok( (!grep { exists $strap->{$_} } qw(max todo skip_all)),
  66         "  max, todo and skip_all are not set" );
  67 }
  68
  69
  70 my @attribs = qw(max skip_all todo);
  71 my %headers = (
  72    '1..2'                               => { max => 2 },
  73    '1..1'                               => { max => 1 },
  74    '1..0'                               => { max => 0,
  75                                              skip_all => '',
  76                                            },
  77    '1..0 # Skipped: no leverage found'  => { max      => 0,
  78                                              skip_all => 'no leverage found',
  79                                            },
  80    '1..4 # Skipped: no leverage found'  => { max      => 4,
  81                                              skip_all => 'no leverage found',
  82                                            },
  83    '1..0 # skip skip skip because'      => { max      => 0,
  84                                              skip_all => 'skip skip because',
  85                                            },
  86    '1..10 todo 2 4 10'                  => { max        => 10,
  87                                              'todo'       => { 2  => 1,
  88                                                                4  => 1,
  89                                                                10 => 1,
  90                                                            },
  91                                            },
  92    '1..10 todo'                         => { max        => 10 },
  93    '1..192 todo 4 2 13 192 # Skip skip skip because'   =>
  94                                            { max     => 192,
  95                                              'todo'    => { 4   => 1,
  96                                                             2   => 1,
  97                                                             13  => 1,
  98                                                             192 => 1,
  99                                                         },
 100                                              skip_all => 'skip skip because'
 101                                            }
 102 );
 103
 104 while( my($header, $expect) = each %headers ) {
 105     my $strap = Test::Harness::Straps->new;
 106     isa_ok( $strap, 'Test::Harness::Straps' );
 107
 108     ok( $strap->_is_header($header),    "_is_header() is a header '$header'" );
 109
 110     is( $strap->{skip_all}, $expect->{skip_all},      '  skip_all set right' )
 111       if defined $expect->{skip_all};
 112
 113     ok( eq_set( [map $strap->{$_},  grep defined $strap->{$_},  @attribs],
 114                 [map $expect->{$_}, grep defined $expect->{$_}, @attribs] ),
 115         '  the right attributes are there' );
 116 }
 117
 118
 119
 120 ### Testing _is_test()
 121
 122 my %tests = (
 123              'ok'       => { 'ok' => 1 },
 124              'not ok'   => { 'ok' => 0 },
 125
 126              'ok 1'     => { 'ok' => 1, number => 1 },
 127              'not ok 1' => { 'ok' => 0, number => 1 },
 128
 129              'ok 2938'  => { 'ok' => 1, number => 2938 },
 130
 131              'ok 1066 - and all that'   => { 'ok'     => 1,
 132                                              number => 1066,
 133                                              name   => "- and all that" },
 134              'not ok 42 - universal constant'   =>
 135                                       { 'ok'     => 0,
 136                                         number => 42,
 137                                         name   => '- universal constant',
 138                                       },
 139              'not ok 23 # TODO world peace'     => { 'ok'     => 0,
 140                                                      number => 23,
 141                                                      type   => 'todo',
 142                                                      reason => 'world peace'
 143                                                    },
 144              'ok 11 - have life # TODO get a life'  =>
 145                                       { 'ok'     => 1,
 146                                         number => 11,
 147                                         name   => '- have life',
 148                                         type   => 'todo',
 149                                         reason => 'get a life'
 150                                       },
 151              'not ok # TODO'    => { 'ok'     => 0,
 152                                      type   => 'todo',
 153                                      reason => ''
 154                                    },
 155              'ok # skip'        => { 'ok'     => 1,
 156                                      type   => 'skip',
 157                                    },
 158              'not ok 11 - this is \# all the name # skip this is not'
 159                                 => { 'ok'     => 0,
 160                                      number => 11,
 161                                      name   => '- this is \# all the name',
 162                                      type   => 'skip',
 163                                      reason => 'this is not'
 164                                    },
 165              "ok 42 - _is_header() is a header '1..192 todo 4 2 13 192 \\# Skip skip skip because"
 166                                 => { 'ok'   => 1,
 167                                      number => 42,
 168                                      name   => "- _is_header() is a header '1..192 todo 4 2 13 192 \\# Skip skip skip because",
 169                                    },
 170             );
 171
 172 while( my($line, $expect) = each %tests ) {
 173     my %test;
 174     ok( $strap->_is_test($line, \%test),    "_is_test() spots '$line'" );
 175
 176     foreach my $type (qw(ok number name type reason)) {
 177         cmp_ok( $test{$type}, 'eq', $expect->{$type}, "  $type" );
 178     }
 179 }
 180
 181 my @untests = (
 182                ' ok',
 183                'not',
 184                'okay 23',
 185               );
 186 foreach my $line (@untests) {
 187     my $strap = Test::Harness::Straps->new;
 188     isa_ok( $strap, 'Test::Harness::Straps' );
 189
 190     my %test = ();
 191     ok( !$strap->_is_test($line, \%test),    "_is_test() disregards '$line'" );
 192
 193     # is( keys %test, 0 ) won't work in 5.004 because it's undef.
 194     ok( !keys %test,                         '  and produces no test info'   );
 195 }
 196
 197
 198 ### Test _is_bail_out()
 199
 200 my %bails = (
 201              'Bail out!'                 =>  undef,
 202              'Bail out!  Wing on fire.'  => 'Wing on fire.',
 203              'BAIL OUT!'                 => undef,
 204              'bail out! - Out of coffee' => '- Out of coffee',
 205             );
 206
 207 while( my($line, $expect) = each %bails ) {
 208     my $strap = Test::Harness::Straps->new;
 209     isa_ok( $strap, 'Test::Harness::Straps' );
 210
 211     my $reason;
 212     ok( $strap->_is_bail_out($line, \$reason), "_is_bail_out() spots '$line'");
 213     is( $reason, $expect,                       '  with the right reason' );
 214 }
 215
 216 my @unbails = (
 217                '  Bail out!',
 218                'BAIL OUT',
 219                'frobnitz',
 220                'ok 23 - BAIL OUT!',
 221               );
 222
 223 foreach my $line (@unbails) {
 224     my $strap = Test::Harness::Straps->new;
 225     isa_ok( $strap, 'Test::Harness::Straps' );
 226
 227     my $reason;
 228
 229     ok( !$strap->_is_bail_out($line, \$reason),
 230                                        "_is_bail_out() ignores '$line'" );
 231     is( $reason, undef,                         '  and gives no reason' );
 232 }