1#!/usr/bin/perl -Tw
2
3use strict;
4
5BEGIN {
6    if( $ENV{PERL_CORE} ) {
7        chdir 't';
8        @INC = ('../lib', 'lib');
9    }
10    else {
11        unshift @INC, 't/lib';
12    }
13}
14
15use Test::More tests => 89;
16
17BEGIN { use_ok('Test::Harness::Straps'); }
18
19my $strap = Test::Harness::Straps->new;
20isa_ok( $strap, 'Test::Harness::Straps', 'new()' );
21
22### Testing _is_diagnostic()
23
24my $comment;
25ok( !$strap->_is_diagnostic("foo", \$comment), '_is_diagnostic(), not a comment'  );
26ok( !defined $comment,                      '  no comment set'              );
27
28ok( !$strap->_is_diagnostic("f # oo", \$comment), '  not a comment with #'     );
29ok( !defined $comment,                         '  no comment set'           );
30
31my %comments = (
32                "# stuff and things # and stuff"    =>
33                                        ' stuff and things # and stuff',
34                "    # more things "                => ' more things ',
35                "#"                                 => '',
36               );
37
38for 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
52my @not_headers = (' 1..2',
53                   '1..M',
54                   '1..-1',
55                   '2..2',
56                   '1..a',
57                   '',
58                  );
59
60foreach 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
72my @attribs = qw(max skip_all todo);
73my %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
106for 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
125my %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
132for 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
142my @unbails = (
143               '  Bail out!',
144               'BAIL OUT',
145               'frobnitz',
146               'ok 23 - BAIL OUT!',
147              );
148
149foreach 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}
159