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 => 89;
  16
  17 BEGIN { 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_diagnostic()
  23
  24 my $comment;
  25 ok( !$strap->_is_diagnostic("foo", \$comment), '_is_diagnostic(), not a comment'  );
  26 ok( !defined $comment,                      '  no comment set'              );
  27
  28 ok( !$strap->_is_diagnostic("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 for my $line ( sort keys %comments ) {
  39     my $line_comment = $comments{$line};
  40     my $strap = Test::Harness::Straps->new;
  41     isa_ok( $strap, 'Test::Harness::Straps' );
  42
  43     my $name = substr($line, 0, 20);
  44     ok( $strap->_is_diagnostic($line, \$comment),        "  comment '$name'"   );
  45     is( $comment, $line_comment,                      '  right comment set' );
  46 }
  47
  48
  49
  50 ### Testing _is_header()
  51
  52 my @not_headers = (' 1..2',
  53                    '1..M',
  54                    '1..-1',
  55                    '2..2',
  56                    '1..a',
  57                    '',
  58                   );
  59
  60 foreach my $unheader (@not_headers) {
  61     my $strap = Test::Harness::Straps->new;
  62     isa_ok( $strap, 'Test::Harness::Straps' );
  63
  64     ok( !$strap->_is_header($unheader),
  65         "_is_header(), not a header '$unheader'" );
  66
  67     ok( (!grep { exists $strap->{$_} } qw(max todo skip_all)),
  68         "  max, todo and skip_all are not set" );
  69 }
  70
  71
  72 my @attribs = qw(max skip_all todo);
  73 my %headers = (
  74    '1..2'                               => { max => 2 },
  75    '1..1'                               => { max => 1 },
  76    '1..0'                               => { max => 0,
  77                                              skip_all => '',
  78                                            },
  79    '1..0 # Skipped: no leverage found'  => { max      => 0,
  80                                              skip_all => 'no leverage found',
  81                                            },
  82    '1..4 # Skipped: no leverage found'  => { max      => 4,
  83                                              skip_all => 'no leverage found',
  84                                            },
  85    '1..0 # skip skip skip because'      => { max      => 0,
  86                                              skip_all => 'skip skip because',
  87                                            },
  88    '1..10 todo 2 4 10'                  => { max        => 10,
  89                                              'todo'       => { 2  => 1,
  90                                                                4  => 1,
  91                                                                10 => 1,
  92                                                            },
  93                                            },
  94    '1..10 todo'                         => { max        => 10 },
  95    '1..192 todo 4 2 13 192 # Skip skip skip because'   =>
  96                                            { max     => 192,
  97                                              'todo'    => { 4   => 1,
  98                                                             2   => 1,
  99                                                             13  => 1,
 100                                                             192 => 1,
 101                                                         },
 102                                              skip_all => 'skip skip because'
 103                                            }
 104 );
 105
 106 for my $header ( sort keys %headers ) {
 107     my $expect = $headers{$header};
 108     my $strap = Test::Harness::Straps->new;
 109     isa_ok( $strap, 'Test::Harness::Straps' );
 110
 111     ok( $strap->_is_header($header),    "_is_header() is a header '$header'" );
 112
 113     is( $strap->{skip_all}, $expect->{skip_all},      '  skip_all set right' )
 114       if defined $expect->{skip_all};
 115
 116     ok( eq_set( [map $strap->{$_},  grep defined $strap->{$_},  @attribs],
 117                 [map $expect->{$_}, grep defined $expect->{$_}, @attribs] ),
 118         '  the right attributes are there' );
 119 }
 120
 121
 122
 123 ### Test _is_bail_out()
 124
 125 my %bails = (
 126              'Bail out!'                 =>  undef,
 127              'Bail out!  Wing on fire.'  => 'Wing on fire.',
 128              'BAIL OUT!'                 => undef,
 129              'bail out! - Out of coffee' => '- Out of coffee',
 130             );
 131
 132 for my $line ( sort keys %bails ) {
 133     my $expect = $bails{$line};
 134     my $strap = Test::Harness::Straps->new;
 135     isa_ok( $strap, 'Test::Harness::Straps' );
 136
 137     my $reason;
 138     ok( $strap->_is_bail_out($line, \$reason), "_is_bail_out() spots '$line'");
 139     is( $reason, $expect,                       '  with the right reason' );
 140 }
 141
 142 my @unbails = (
 143                '  Bail out!',
 144                'BAIL OUT',
 145                'frobnitz',
 146                'ok 23 - BAIL OUT!',
 147               );
 148
 149 foreach my $line (@unbails) {
 150     my $strap = Test::Harness::Straps->new;
 151     isa_ok( $strap, 'Test::Harness::Straps' );
 152
 153     my $reason;
 154
 155     ok( !$strap->_is_bail_out($line, \$reason),
 156                                        "_is_bail_out() ignores '$line'" );
 157     is( $reason, undef,                         '  and gives no reason' );
 158 }