Upgrade to CGI.pm-3.31. Includes version bump to CGI::Carp due to a Pod fix.

[p5sagit/p5-mst-13.2.git] / lib / Test / Harness / t / strap.t

#!/usr/bin/perl -Tw

use strict;

BEGIN {
    if( $ENV{PERL_CORE} ) {
        chdir 't';
        @INC = ('../lib', 'lib');
    }
    else {
        unshift @INC, 't/lib';
    }
}

use Test::More tests => 89;

BEGIN { use_ok('Test::Harness::Straps'); }

my $strap = Test::Harness::Straps->new;
isa_ok( $strap, 'Test::Harness::Straps', 'new()' );

### Testing _is_diagnostic()

my $comment;
ok( !$strap->_is_diagnostic("foo", \$comment), '_is_diagnostic(), not a comment'  );
ok( !defined $comment,                      '  no comment set'              );

ok( !$strap->_is_diagnostic("f # oo", \$comment), '  not a comment with #'     );
ok( !defined $comment,                         '  no comment set'           );

my %comments = (
                "# stuff and things # and stuff"    => 
                                        ' stuff and things # and stuff',
                "    # more things "                => ' more things ',
                "#"                                 => '',
               );

for my $line ( sort keys %comments ) {
    my $line_comment = $comments{$line};
    my $strap = Test::Harness::Straps->new;
    isa_ok( $strap, 'Test::Harness::Straps' );

    my $name = substr($line, 0, 20);
    ok( $strap->_is_diagnostic($line, \$comment),        "  comment '$name'"   );
    is( $comment, $line_comment,                      '  right comment set' );
}



### Testing _is_header()

my @not_headers = (' 1..2',
                   '1..M',
                   '1..-1',
                   '2..2',
                   '1..a',
                   '',
                  );

foreach my $unheader (@not_headers) {
    my $strap = Test::Harness::Straps->new;
    isa_ok( $strap, 'Test::Harness::Straps' );

    ok( !$strap->_is_header($unheader),     
        "_is_header(), not a header '$unheader'" );

    ok( (!grep { exists $strap->{$_} } qw(max todo skip_all)),
        "  max, todo and skip_all are not set" );
}


my @attribs = qw(max skip_all todo);
my %headers = (
   '1..2'                               => { max => 2 },
   '1..1'                               => { max => 1 },
   '1..0'                               => { max => 0,
                                             skip_all => '',
                                           },
   '1..0 # Skipped: no leverage found'  => { max      => 0,
                                             skip_all => 'no leverage found',
                                           },
   '1..4 # Skipped: no leverage found'  => { max      => 4,
                                             skip_all => 'no leverage found',
                                           },
   '1..0 # skip skip skip because'      => { max      => 0,
                                             skip_all => 'skip skip because',
                                           },
   '1..10 todo 2 4 10'                  => { max        => 10,
                                             'todo'       => { 2  => 1,
                                                               4  => 1,
                                                               10 => 1,
                                                           },
                                           },
   '1..10 todo'                         => { max        => 10 },
   '1..192 todo 4 2 13 192 # Skip skip skip because'   => 
                                           { max     => 192,
                                             'todo'    => { 4   => 1, 
                                                            2   => 1, 
                                                            13  => 1, 
                                                            192 => 1,
                                                        },
                                             skip_all => 'skip skip because'
                                           }
);

for my $header ( sort keys %headers ) {
    my $expect = $headers{$header};
    my $strap = Test::Harness::Straps->new;
    isa_ok( $strap, 'Test::Harness::Straps' );

    ok( $strap->_is_header($header),    "_is_header() is a header '$header'" );

    is( $strap->{skip_all}, $expect->{skip_all},      '  skip_all set right' )
      if defined $expect->{skip_all};

    ok( eq_set( [map $strap->{$_},  grep defined $strap->{$_},  @attribs],
                [map $expect->{$_}, grep defined $expect->{$_}, @attribs] ),
        '  the right attributes are there' );
}



### Test _is_bail_out()

my %bails = (
             'Bail out!'                 =>  undef,
             'Bail out!  Wing on fire.'  => 'Wing on fire.',
             'BAIL OUT!'                 => undef,
             'bail out! - Out of coffee' => '- Out of coffee',
            );

for my $line ( sort keys %bails ) {
    my $expect = $bails{$line};
    my $strap = Test::Harness::Straps->new;
    isa_ok( $strap, 'Test::Harness::Straps' );

    my $reason;
    ok( $strap->_is_bail_out($line, \$reason), "_is_bail_out() spots '$line'");
    is( $reason, $expect,                       '  with the right reason' );
}

my @unbails = (
               '  Bail out!',
               'BAIL OUT',
               'frobnitz',
               'ok 23 - BAIL OUT!',
              );

foreach my $line (@unbails) {
    my $strap = Test::Harness::Straps->new;
    isa_ok( $strap, 'Test::Harness::Straps' );

    my $reason;

    ok( !$strap->_is_bail_out($line, \$reason),  
                                       "_is_bail_out() ignores '$line'" );
    is( $reason, undef,                         '  and gives no reason' );
}