File Coverage

blib/lib/Test/Group/Tester.pm
Criterion Covered Total %
statement 76 131 58.0
branch 27 64 42.1
condition 4 17 23.5
subroutine 10 12 83.3
pod 3 3 100.0
total 120 227 52.8


line stmt bran cond sub pod time code
1             package Test::Group::Tester;
2 8     8   118630 use strict;
  8         18  
  8         294  
3 8     8   47 use warnings;
  8         36  
  8         334  
4              
5 8     8   44 use Carp;
  8         13  
  8         650  
6 8     8   326 use Config;
  8         16  
  8         360  
7 8     8   3923 use Test::Builder;
  8         12315  
  8         170  
8 8     8   9565 use Test::Cmd;
  8         262208  
  8         1934  
9              
10             =head1 NAME
11              
12             Test::Group::Tester - Test Test::Group extensions
13              
14             =head1 VERSION
15              
16             Test::Group::Tester version 0.01
17              
18             =cut
19              
20 8     8   182 use vars qw($VERSION);
  8         21  
  8         525  
21             $VERSION = '0.01';
22              
23             =head1 SYNOPSIS
24              
25             =for tests "synopsis" begin
26              
27             use Test::More tests => 1;
28             use Test::Group::Tester;
29              
30             testscript_ok('#line '.(__LINE__+1)."\n".<<'EOSCRIPT', 3);
31              
32             use Test::More;
33             use Test::Group;
34              
35             # Test a passing test group
36             want_test('pass', "this_should_pass");
37             test this_should_pass => sub {
38             ok 1, "1 is true";
39             ok 2, "2 is true";
40             };
41              
42             # Test a failing test group
43             want_test('fail', "this_should_fail",
44             fail_diag("0 is true", 0, __LINE__+5),
45             fail_diag("this_should_fail", 1, __LINE__+5),
46             );
47             test this_should_fail => sub {
48             ok 1, "1 is true";
49             ok 0, "0 is true";
50             };
51              
52             # Test a skipped test group
53             want_test('skip', "just because I can");
54             skip_next_test("just because I can");
55             test this_should_be_skipped => sub {
56             ok 0;
57             };
58              
59             EOSCRIPT
60              
61             =for tests "synopsis" end
62              
63             =head1 DESCRIPTION
64              
65             Test the behavior of a L compatible test script, by
66             spawning an external process to run the script and capturing its STDOUT
67             and STDERR. Includes support for matching the failed test diagnostic
68             messages produced by L and L.
69              
70             Useful when writing tests for L extension modules, see
71             L.
72              
73             This module is used within the test suite of L itself, so
74             several usage examples can be found by searching for C in
75             the files in L's F subdirectory.
76              
77             =head1 FUNCTIONS EXPORTED BY DEFAULT
78              
79             =cut
80              
81 8     8   49 use Exporter;
  8         53  
  8         410  
82 8     8   53 use vars qw(@ISA @EXPORT @EXPORT_OK);
  8         17  
  8         18083  
83             @ISA = qw(Exporter);
84             @EXPORT = qw(testscript_ok);
85             @EXPORT_OK = qw(want_test fail_diag);
86              
87             =over
88              
89             =item I
90              
91             A test predicate for checking that a test script acts as expected. Runs
92             the script capturing STDOUT and STDERR and fails if anything unexpected
93             happens.
94              
95             The expected behavior of the script is defined by calling want_test()
96             from within the script, just before running each test.
97              
98             I<$source> is the body of the test script, as a single multi-line string.
99              
100             I<$plan> is the number of tests that the test script will run.
101              
102             I<$name> is a name for this test.
103              
104             Some code will be prepended to I<$source>, to make the want_test() and
105             fail_diag() functions available and to set the test plan to I<$plan>.
106              
107             Tip: include a C<#line> directive in your script source as shown in the
108             SYNOPSIS above, so that the reported line numbers for problems will point
109             to the correct line in your source file.
110              
111             =cut
112              
113             sub testscript_ok {
114 15     15 1 41269 my ($source, $plan, $name) = @_;
115 15 50       171 $plan =~ /^\d+$/ or croak "non-numeric plan [$plan]";
116 15   100     120 $name ||= 'testscript_ok';
117              
118 15         42 local $Test::Builder::Level = $Test::Builder::Level + 1;
119              
120 15         223 my $script_source = <
121             use Test::Builder;
122             Test::Builder->new->plan( tests => $plan );
123             use Test::Group::Tester qw(want_test fail_diag);
124              
125             $source
126              
127             print STDERR "\nXXtestscript_under_test_endXX\n";
128             EOSCRIPT
129              
130 163         29632 my $perl = Test::Cmd->new
131             (prog => join(' ', $Config{perlpath},
132 15         8954 (map { ("-I", $_) } @INC), '-'),
133             workdir => '');
134 15 50       566627 $perl or croak "$name Test::Cmd failed";
135              
136 15         417 my $status = $perl->run(stdin => $script_source);
137 15         3195136 my $stdout = $perl->stdout();
138 15         4710 my $stderr = $perl->stderr();
139 15         5514 $stderr =~ s/\nXXtestscript_under_test_endXX\n.*//s;
140              
141 15         112 my $ok = 1;
142 15         78 my $expect_failed_tests = 0;
143 15         62 my @fail;
144              
145 15         253 my @errbits = split /XXwant_test_markerXX/, $stderr, -1;
146 15         97 my $preamble = shift @errbits;
147 15 50       162 if (length $preamble) {
148 0         0 $ok = 0;
149 0         0 push @fail, "STDERR output before first test:";
150 0         0 push @fail, " $preamble";
151             }
152 15         99 my $rantests = @errbits;
153 15 50       189 unless ($rantests == $plan) {
154 0         0 $ok = 0;
155 0         0 push @fail, "planned $plan tests, script ran $rantests";
156             }
157              
158 15         75 my $want_out = "1..$plan\n";
159 15         117 foreach my $i (0 .. $#errbits) {
160 97         198 my $e = $errbits[$i];
161 97 50       1112 unless ($e =~ s/^ want_test:([,\w]+)\n//) {
162 0         0 $ok = 0;
163 0         0 push @fail, "missing header in section [$e]";
164 0         0 next;
165             }
166 652 100       3787 my ($call_line, $type, $name, @diag) =
167 97         692 map { $_ eq 'undef' ? undef : pack 'H*', $_} split /,/, $1, -1;
168              
169 97 100       629 my $out = ($type eq 'fail' ? 'not ' : '') . 'ok ' . ($i+1);
170 97 100       347 if ($type eq 'skip') {
171 3         6 $out .= " # skip";
172 3 50       23 defined $name and $out .= " $name";
173             } else {
174 94 100       351 defined $name and $out .= " - $name";
175             }
176 97         1475 $want_out .= "$out\n";
177              
178 97 100       253 ++$expect_failed_tests if $type eq 'fail';
179              
180 97         327 $e =~ s/\n$//;
181 97         352 my @lines = split /\n/, $e, -1;
182 97         131 my @mismatch;
183 97         236 foreach my $i (0 .. $#lines) {
184 361 50       1087 last if @mismatch;
185 361         583 my $line = $lines[$i];
186 361         457 my $want = $diag[$i];
187 361 50       1717 if (!defined $want) {
    100          
    50          
188 0         0 push @mismatch, "unmatched line '$line'";
189             } elsif ($want =~ s{^/}{}) {
190 135 50       5609 unless ($line =~ /$want/) {
191 0         0 push @mismatch,
192             "line '$line'",
193             "doesn't match /$want/";
194             }
195             } elsif ($line ne $want) {
196 0         0 push @mismatch,
197             "line '$line'",
198             "isnt '$want'";
199             }
200             }
201 97 50       277 if (@lines < @diag) {
202 0         0 push @mismatch, "too few lines";
203             }
204 97 50       807 if (@mismatch) {
205 0         0 $ok = 0;
206 0         0 my $msg = "STDERR MISMATCH";
207 0 0       0 defined $name and $msg .= " FOR $name";
208 0         0 $msg .= " (line $call_line)";
209 0         0 push @fail, "$msg...",
210             " got stderr:",
211 0         0 map({" [$_]"} @lines),
212             " want stderr:",
213 0         0 map({" [$_]"} @diag),
214             " mismatch details:",
215 0         0 map({" $_"} @mismatch),
216             ;
217            
218             }
219             }
220              
221 15 50       88 if ($stdout ne $want_out) {
222 0         0 $ok = 0;
223 0         0 push @fail, "want stdout: $want_out",
224             "got stdout: $stdout";
225             }
226              
227 15 50 33     319 if ($expect_failed_tests and not $status) {
    50 33        
228 0         0 $ok = 0;
229 0         0 push @fail, "test script failed to fail";
230             } elsif ($status and not $expect_failed_tests) {
231 0         0 $ok = 0;
232 0         0 push @fail, "test script unexpectedly failed";
233             }
234              
235 15         388 my $Test = Test::Builder->new;
236 15         526 $Test->ok($ok, $name);
237 15         18837 foreach my $fail (@fail) {
238 0           $Test->diag("* $fail");
239             }
240             }
241              
242             =back
243              
244             =head1 TEST SCRIPT FUNCTIONS
245              
246             The following functions are for use from within the script under test.
247             They are not exported by default.
248              
249             =over
250              
251             =item I
252              
253             Declares that the next test will pass or fail or be skipped according to
254             I<$type>, will have name I<$name> and will produce the diagnostic output
255             lines listed in I<@diag>.
256              
257             I<$type> must be one of the strings 'pass', 'fail', 'skip'. I<$name>
258             can be undef for a test without a name. The elements of I<@diag> can
259             be strings for an exact match, or regular expressions prefixed with
260             C or compiled with C.
261              
262             Note that diagnostic lines consist of a hash character followed by a
263             space and then the diagnostic message. The strings and patterns passed
264             to want_test() must include this prefix.
265              
266             =cut
267              
268             sub want_test {
269 0     0 1   my ($type, $name, @diag) = @_;
270 0           my $call_line = (caller)[2];
271              
272 0 0         $type =~ /^(pass|fail|skip)\z/i or croak
273             "want_test type=[$type], need pass|fail|skip";
274 0           $type = lc $1;
275              
276             # flatten diags to strings
277 0           foreach my $diag (@diag) {
278 0 0         ref $diag eq 'Regexp' and $diag = "/$diag";
279 0 0         ref $diag and croak "unexpected reference diag [$diag] in want_test";
280             }
281              
282 0 0         my @args = map {defined $_ ? unpack('H*', $_) : 'undef'}
  0            
283             $call_line, $type, $name, @diag;
284 0           print STDERR 'XXwant_test_markerXX want_test:', join(',', @args), "\n";
285             }
286              
287             =item I
288              
289             Call only in a list context, and pass the results to want_test() as
290             diagnostic line patterns.
291              
292             Returns the diagnostic line pattern(s) to match output from a failed
293             test. I<$test_name> is the name of the test, or undef for a nameless
294             test. I<$line> should be defined only if a file and line diagnostic
295             is expected, and should give the expected line number. I<$file> is
296             the filename for the failed test diagnostic, it defaults to the
297             current file.
298              
299             C<$from_test_builder> should be true if L will produce
300             the diagnostic, false if the diagnostic will come from L.
301             The expected text will be adjusted according to the version of
302             L or L in use.
303              
304             =cut
305              
306             sub fail_diag {
307 0 0   0 1   wantarray or croak "fail_diag needs a list context";
308              
309 0           my ($test_name, $from_test_builder, $line, $file) = @_;
310 0   0       $file ||= (caller)[1];
311              
312 0           my @diag;
313              
314 0 0 0       if ($from_test_builder and $ENV{HARNESS_ACTIVE}) {
315             # Test::Builder adds a blank diag line for a failed test
316             # if HARNESS_ACTIVE is set.
317 0           push @diag, '';
318             }
319              
320 0 0 0       if ($from_test_builder and $Test::Builder::VERSION <= 0.30) {
321 0           my $diag = "# Failed test";
322 0 0         if (defined $line) {
323 0           $diag .= " ($file at line $line)";
324             }
325 0           push @diag, $diag;
326             } else {
327 0 0         if (defined $test_name) {
328 0           push @diag, "# Failed test '$test_name'";
329             } else {
330 0           push @diag, "# Failed test";
331             }
332 0 0         if (defined $line) {
333 0           my $qm = quotemeta $file;
334 0           push @diag, "/^\\#\\s+(at $qm|in $qm at) line $line\\.?\\s*\$";
335             }
336             }
337              
338 0           return @diag;
339             }
340              
341             =back
342              
343             =head1 AUTHORS
344              
345             Nick Cleaton
346              
347             Dominique Quatravaux
348              
349             =head1 LICENSE
350              
351             Copyright (c) 2009 by Nick Cleaton and Dominique Quatravaux
352              
353             This library is free software; you can redistribute it and/or modify
354             it under the same terms as Perl itself, either Perl version 5.8.1 or,
355             at your option, any later version of Perl 5 you may have available.
356              
357             =cut
358              
359             1;