File Coverage

blib/lib/Test/Output.pm
Criterion Covered Total %
statement 270 271 99.6
branch 134 152 88.1
condition 12 12 100.0
subroutine 31 32 96.8
pod 20 20 100.0
total 467 487 95.8


line stmt bran cond sub pod time code
1 19     19   1200693 use 5.008;
  19         193  
2              
3             package Test::Output;
4              
5 19     19   96 use warnings;
  19         34  
  19         529  
6 19     19   85 use strict;
  19         32  
  19         404  
7              
8 19     19   93 use Test::Builder;
  19         33  
  19         561  
9 19     19   9319 use Capture::Tiny qw/capture capture_stdout capture_stderr capture_merged/;
  19         473351  
  19         1376  
10              
11 19     19   161 use Exporter qw(import);
  19         59  
  19         51590  
12              
13             our %EXPORT_TAGS = (
14             stdout => [
15             qw(
16             stdout_is stdout_isnt stdout_like stdout_unlike
17             )
18             ],
19             stderr => [
20             qw(
21             stderr_is stderr_isnt stderr_like stderr_unlike
22             )
23             ],
24             output => [
25             qw(
26             output_is output_isnt output_like output_unlike
27             )
28             ],
29             combined => [
30             qw(
31             combined_is combined_isnt combined_like combined_unlike
32             )
33             ],
34             functions => [
35             qw(
36             output_from stderr_from stdout_from combined_from
37             )
38             ],
39             tests => [
40             qw(
41             output_is output_isnt output_like output_unlike
42             stderr_is stderr_isnt stderr_like stderr_unlike
43             stdout_is stdout_isnt stdout_like stdout_unlike
44             combined_is combined_isnt combined_like combined_unlike
45             )
46             ],
47             all => [
48             qw(
49             output_is output_isnt output_like output_unlike
50             stderr_is stderr_isnt stderr_like stderr_unlike
51             stdout_is stdout_isnt stdout_like stdout_unlike
52             combined_is combined_isnt combined_like combined_unlike
53             output_from stderr_from stdout_from combined_from
54             )
55             ],
56             );
57              
58             our @EXPORT = keys %{
59             {
60             map { $_ => 1 }
61             map {
62             @{ $EXPORT_TAGS{$_} }
63             }
64             keys %EXPORT_TAGS
65             }
66             };
67              
68             my $Test = Test::Builder->new;
69              
70             =encoding utf8
71              
72             =head1 NAME
73              
74             Test::Output - Utilities to test STDOUT and STDERR messages.
75              
76             =cut
77              
78             our $VERSION = '1.033';
79              
80             =head1 SYNOPSIS
81              
82             use Test::More tests => 4;
83             use Test::Output;
84              
85             sub writer {
86             print "Write out.\n";
87             print STDERR "Error out.\n";
88             }
89              
90             stdout_is(\&writer,"Write out.\n",'Test STDOUT');
91              
92             stderr_isnt(\&writer,"No error out.\n",'Test STDERR');
93              
94             combined_is(
95             \&writer,
96             "Write out.\nError out.\n",
97             'Test STDOUT & STDERR combined'
98             );
99              
100             output_is(
101             \&writer,
102             "Write out.\n",
103             "Error out.\n",
104             'Test STDOUT & STDERR'
105             );
106              
107             # Use bare blocks.
108              
109             stdout_is { print "test" } "test", "Test STDOUT";
110             stderr_isnt { print "bad test" } "test", "Test STDERR";
111             output_is { print 'STDOUT'; print STDERR 'STDERR' }
112             "STDOUT", "STDERR", "Test output";
113              
114             =head1 DESCRIPTION
115              
116             Test::Output provides a simple interface for testing output sent to C
117             or C. A number of different utilities are included to try and be as
118             flexible as possible to the tester.
119              
120             Likewise, L provides a much more robust capture mechanism without
121             than the original L.
122              
123             =cut
124              
125             =head1 TESTS
126              
127             =cut
128              
129             =head2 STDOUT
130              
131             =over 4
132              
133             =item B
134              
135             =item B
136              
137             stdout_is ( $coderef, $expected, 'description' );
138             stdout_is { ... } $expected, 'description';
139             stdout_isnt( $coderef, $expected, 'description' );
140             stdout_isnt { ... } $expected, 'description';
141              
142             C captures output sent to C from C<$coderef> and compares
143             it against C<$expected>. The test passes if equal.
144              
145             C passes if C is not equal to C<$expected>.
146              
147             =cut
148              
149             sub stdout_is (&$;$$) {
150 6     6 1 13817 my $test = shift;
151 6         11 my $expected = shift;
152 6 50       20 my $options = shift if ( ref( $_[0] ) );
153 6         13 my $description = shift;
154              
155 6         16 my $stdout = stdout_from($test);
156              
157 6         25 my $ok = ( $stdout eq $expected );
158              
159 6 100       62 $Test->ok( $ok, $description )
160             || $Test->diag("STDOUT is:\n$stdout\nnot:\n$expected\nas expected");
161              
162 6         2724 return $ok;
163             }
164              
165             sub stdout_isnt (&$;$$) {
166 6     6 1 13760 my $test = shift;
167 6         13 my $expected = shift;
168 6 50       22 my $options = shift if ( ref( $_[0] ) );
169 6         12 my $description = shift;
170              
171 6         20 my $stdout = stdout_from($test);
172              
173 6         22 my $ok = ( $stdout ne $expected );
174              
175 6 100       71 $Test->ok( $ok, $description )
176             || $Test->diag("STDOUT:\n$stdout\nmatching:\n$expected\nnot expected");
177              
178 6         2845 return $ok;
179             }
180              
181             =item B
182              
183             =item B
184              
185             stdout_like ( $coderef, qr/$expected/, 'description' );
186             stdout_like { ... } qr/$expected/, 'description';
187             stdout_unlike( $coderef, qr/$expected/, 'description' );
188             stdout_unlike { ... } qr/$expected/, 'description';
189              
190             C captures the output sent to C from C<$coderef> and compares
191             it to the regex in C<$expected>. The test passes if the regex matches.
192              
193             C passes if STDOUT does not match the regex.
194              
195             =back
196              
197             =cut
198              
199             sub stdout_like (&$;$$) {
200 6     6 1 12696 my $test = shift;
201 6         10 my $expected = shift;
202 6 50       13 my $options = shift if ( ref( $_[0] ) );
203 6         9 my $description = shift;
204              
205 6 100       12 unless ( my $regextest = _chkregex( 'stdout_like' => $expected ) ) {
206 2         4 return $regextest;
207             }
208              
209 4         8 my $stdout = stdout_from($test);
210              
211 4         22 my $ok = ( $stdout =~ $expected );
212              
213 4 100       26 $Test->ok( $ok, $description )
214             || $Test->diag("STDOUT:\n$stdout\ndoesn't match:\n$expected\nas expected");
215              
216 4         1675 return $ok;
217             }
218              
219             sub stdout_unlike (&$;$$) {
220 6     6 1 12651 my $test = shift;
221 6         9 my $expected = shift;
222 6 50       14 my $options = shift if ( ref( $_[0] ) );
223 6         9 my $description = shift;
224              
225 6 100       13 unless ( my $regextest = _chkregex( 'stdout_unlike' => $expected ) ) {
226 2         5 return $regextest;
227             }
228              
229 4         9 my $stdout = stdout_from($test);
230              
231 4         24 my $ok = ( $stdout !~ $expected );
232              
233 4 100       27 $Test->ok( $ok, $description )
234             || $Test->diag("STDOUT:\n$stdout\nmatches:\n$expected\nnot expected");
235              
236 4         1630 return $ok;
237             }
238              
239             =head2 STDERR
240              
241             =over 4
242              
243             =item B
244              
245             =item B
246              
247             stderr_is ( $coderef, $expected, 'description' );
248             stderr_is {... } $expected, 'description';
249              
250             stderr_isnt( $coderef, $expected, 'description' );
251             stderr_isnt {... } $expected, 'description';
252              
253             C is similar to C, except that it captures C. The
254             test passes if C from C<$coderef> equals C<$expected>.
255              
256             C passes if C is not equal to C<$expected>.
257              
258             =cut
259              
260             sub stderr_is (&$;$$) {
261 6     6 1 12824 my $test = shift;
262 6         9 my $expected = shift;
263 6 50       13 my $options = shift if ( ref( $_[0] ) );
264 6         8 my $description = shift;
265              
266 6         10 my $stderr = stderr_from($test);
267              
268 6         12 my $ok = ( $stderr eq $expected );
269              
270 6 100       41 $Test->ok( $ok, $description )
271             || $Test->diag("STDERR is:\n$stderr\nnot:\n$expected\nas expected");
272              
273 6         2281 return $ok;
274             }
275              
276             sub stderr_isnt (&$;$$) {
277 4     4 1 10089 my $test = shift;
278 4         5 my $expected = shift;
279 4 50       10 my $options = shift if ( ref( $_[0] ) );
280 4         7 my $description = shift;
281              
282 4         6 my $stderr = stderr_from($test);
283              
284 4         8 my $ok = ( $stderr ne $expected );
285              
286 4 100       28 $Test->ok( $ok, $description )
287             || $Test->diag("STDERR:\n$stderr\nmatches:\n$expected\nnot expected");
288              
289 4         1720 return $ok;
290             }
291              
292             =item B
293              
294             =item B
295              
296             stderr_like ( $coderef, qr/$expected/, 'description' );
297             stderr_like { ...} qr/$expected/, 'description';
298             stderr_unlike( $coderef, qr/$expected/, 'description' );
299             stderr_unlike { ...} qr/$expected/, 'description';
300              
301             C is similar to C except that it compares the regex
302             C<$expected> to C captured from C<$codref>. The test passes if the regex
303             matches.
304              
305             C passes if C does not match the regex.
306              
307             =back
308              
309             =cut
310              
311             sub stderr_like (&$;$$) {
312 6     6 1 16222 my $test = shift;
313 6         9 my $expected = shift;
314 6 50       15 my $options = shift if ( ref( $_[0] ) );
315 6         8 my $description = shift;
316              
317 6 100       10 unless ( my $regextest = _chkregex( 'stderr_like' => $expected ) ) {
318 2         6 return $regextest;
319             }
320              
321 4         8 my $stderr = stderr_from($test);
322              
323 4         24 my $ok = ( $stderr =~ $expected );
324              
325 4 100       26 $Test->ok( $ok, $description )
326             || $Test->diag("STDERR:\n$stderr\ndoesn't match:\n$expected\nas expected");
327              
328 4         1629 return $ok;
329             }
330              
331             sub stderr_unlike (&$;$$) {
332 6     6 1 16513 my $test = shift;
333 6         11 my $expected = shift;
334 6 50       18 my $options = shift if ( ref( $_[0] ) );
335 6         10 my $description = shift;
336              
337 6 100       16 unless ( my $regextest = _chkregex( 'stderr_unlike' => $expected ) ) {
338 2         6 return $regextest;
339             }
340              
341 4         11 my $stderr = stderr_from($test);
342              
343 4         25 my $ok = ( $stderr !~ $expected );
344              
345 4 100       29 $Test->ok( $ok, $description )
346             || $Test->diag("STDERR:\n$stderr\nmatches:\n$expected\nnot expected");
347              
348 4         1825 return $ok;
349             }
350              
351             =head2 COMBINED OUTPUT
352              
353             =over 4
354              
355             =item B
356              
357             =item B
358              
359             combined_is ( $coderef, $expected, 'description' );
360             combined_is {... } $expected, 'description';
361             combined_isnt ( $coderef, $expected, 'description' );
362             combined_isnt {... } $expected, 'description';
363              
364             C directs C to C then captures C. This is
365             equivalent to UNIXs C<< 2>&1 >>. The test passes if the combined C
366             and C from $coderef equals $expected.
367              
368             C passes if combined C and C are not equal
369             to C<$expected>.
370              
371             =cut
372              
373             sub combined_is (&$;$$) {
374 14     14 1 35905 my $test = shift;
375 14         33 my $expected = shift;
376 14 50       51 my $options = shift if ( ref( $_[0] ) );
377 14         28 my $description = shift;
378              
379 14         43 my $combined = combined_from($test);
380              
381 14         46 my $ok = ( $combined eq $expected );
382              
383 14 100       154 $Test->ok( $ok, $description )
384             || $Test->diag(
385             "STDOUT & STDERR are:\n$combined\nnot:\n$expected\nas expected");
386              
387 14         7180 return $ok;
388             }
389              
390             sub combined_isnt (&$;$$) {
391 14     14 1 35498 my $test = shift;
392 14         32 my $expected = shift;
393 14 50       47 my $options = shift if ( ref( $_[0] ) );
394 14         27 my $description = shift;
395              
396 14         54 my $combined = combined_from($test);
397              
398 14         52 my $ok = ( $combined ne $expected );
399              
400 14 100       162 $Test->ok( $ok, $description )
401             || $Test->diag(
402             "STDOUT & STDERR:\n$combined\nmatching:\n$expected\nnot expected");
403              
404 14         7012 return $ok;
405             }
406              
407             =item B
408              
409             =item B
410              
411             combined_like ( $coderef, qr/$expected/, 'description' );
412             combined_like { ...} qr/$expected/, 'description';
413             combined_unlike ( $coderef, qr/$expected/, 'description' );
414             combined_unlike { ...} qr/$expected/, 'description';
415              
416             C is similar to C except that it compares a regex
417             (C<$expected)> to C and C captured from C<$codref>. The test passes if
418             the regex matches.
419              
420             C passes if the combined C and C does not match
421             the regex.
422              
423             =back
424              
425             =cut
426              
427             sub combined_like (&$;$$) {
428 7     7 1 15295 my $test = shift;
429 7         11 my $expected = shift;
430 7 50       16 my $options = shift if ( ref( $_[0] ) );
431 7         10 my $description = shift;
432              
433 7 100       14 unless ( my $regextest = _chkregex( 'combined_like' => $expected ) ) {
434 2         6 return $regextest;
435             }
436              
437 5         11 my $combined = combined_from($test);
438              
439 5         30 my $ok = ( $combined =~ $expected );
440              
441 5 100       33 $Test->ok( $ok, $description )
442             || $Test->diag(
443             "STDOUT & STDERR:\n$combined\ndon't match:\n$expected\nas expected");
444              
445 5         1964 return $ok;
446             }
447              
448             sub combined_unlike (&$;$$) {
449 7     7 1 19898 my $test = shift;
450 7         12 my $expected = shift;
451 7 50       16 my $options = shift if ( ref( $_[0] ) );
452 7         10 my $description = shift;
453              
454 7 100       16 unless ( my $regextest = _chkregex( 'combined_unlike' => $expected ) ) {
455 2         6 return $regextest;
456             }
457              
458 5         11 my $combined = combined_from($test);
459              
460 5         31 my $ok = ( $combined !~ $expected );
461              
462 5 100       32 $Test->ok( $ok, $description )
463             || $Test->diag(
464             "STDOUT & STDERR:\n$combined\nmatching:\n$expected\nnot expected");
465              
466 5         2133 return $ok;
467             }
468              
469             =head2 OUTPUT
470              
471             =over 4
472              
473             =item B
474              
475             =item B
476              
477             output_is ( $coderef, $expected_stdout, $expected_stderr, 'description' );
478             output_is {... } $expected_stdout, $expected_stderr, 'description';
479             output_isnt( $coderef, $expected_stdout, $expected_stderr, 'description' );
480             output_isnt {... } $expected_stdout, $expected_stderr, 'description';
481              
482             The C function is a combination of the C and C
483             functions. For example:
484              
485             output_is(sub {print "foo"; print STDERR "bar";},'foo','bar');
486              
487             is functionally equivalent to
488              
489             stdout_is(sub {print "foo";},'foo')
490             && stderr_is(sub {print STDERR "bar";},'bar');
491              
492             except that C<$coderef> is only executed once.
493              
494             Unlike C and C which ignore STDERR and STDOUT
495             respectively, C requires both C and C to match in order
496             to pass. Setting either C<$expected_stdout> or C<$expected_stderr> to C
497             ignores C or C respectively.
498              
499             output_is(sub {print "foo"; print STDERR "bar";},'foo',undef);
500              
501             is the same as
502              
503             stdout_is(sub {print "foo";},'foo')
504              
505             C provides the opposite function of C. It is a
506             combination of C and C.
507              
508             output_isnt(sub {print "foo"; print STDERR "bar";},'bar','foo');
509              
510             is functionally equivalent to
511              
512             stdout_isnt(sub {print "foo";},'bar')
513             && stderr_isnt(sub {print STDERR "bar";},'foo');
514              
515             As with C, setting either C<$expected_stdout> or C<$expected_stderr> to
516             C ignores the output to that facility.
517              
518             output_isnt(sub {print "foo"; print STDERR "bar";},undef,'foo');
519              
520             is the same as
521              
522             stderr_is(sub {print STDERR "bar";},'foo')
523              
524             =cut
525              
526             sub output_is (&$$;$$) {
527 24     24 1 56687 my $test = shift;
528 24         63 my $expout = shift;
529 24         27 my $experr = shift;
530 24 50       53 my $options = shift if ( ref( $_[0] ) );
531 24         30 my $description = shift;
532              
533 24         41 my ( $stdout, $stderr ) = output_from($test);
534              
535 24         43 my $ok = 1;
536 24         31 my $diag;
537              
538 24 100 100     106 if ( defined($experr) && defined($expout) ) {
    100          
    100          
539 14 100       32 unless ( $stdout eq $expout ) {
540 4         7 $ok = 0;
541 4         13 $diag .= "STDOUT is:\n$stdout\nnot:\n$expout\nas expected";
542             }
543 14 100       26 unless ( $stderr eq $experr ) {
544 4 100       12 $diag .= "\n" unless ($ok);
545 4         6 $ok = 0;
546 4         10 $diag .= "STDERR is:\n$stderr\nnot:\n$experr\nas expected";
547             }
548             }
549             elsif ( defined($expout) ) {
550 2         5 $ok = ( $stdout eq $expout );
551 2         9 $diag .= "STDOUT is:\n$stdout\nnot:\n$expout\nas expected";
552             }
553             elsif ( defined($experr) ) {
554 2         7 $ok = ( $stderr eq $experr );
555 2         8 $diag .= "STDERR is:\n$stderr\nnot:\n$experr\nas expected";
556             }
557             else {
558 6 100       20 unless ( $stdout eq '' ) {
559 2         4 $ok = 0;
560 2         7 $diag .= "STDOUT is:\n$stdout\nnot:\n\nas expected";
561             }
562 6 100       14 unless ( $stderr eq '' ) {
563 4 100       9 $diag .= "\n" unless ($ok);
564 4         6 $ok = 0;
565 4         9 $diag .= "STDERR is:\n$stderr\nnot:\n\nas expected";
566             }
567             }
568              
569 24 100       185 $Test->ok( $ok, $description ) || $Test->diag($diag);
570              
571 24         9152 return $ok;
572             }
573              
574             sub output_isnt (&$$;$$) {
575 24     24 1 72073 my $test = shift;
576 24         55 my $expout = shift;
577 24         46 my $experr = shift;
578 24 50       90 my $options = shift if ( ref( $_[0] ) );
579 24         36 my $description = shift;
580              
581 24         97 my ( $stdout, $stderr ) = output_from($test);
582              
583 24         55 my $ok = 1;
584 24         43 my $diag;
585              
586 24 100 100     196 if ( defined($experr) && defined($expout) ) {
    100          
    100          
587 8 100       34 if ( $stdout eq $expout ) {
588 4         8 $ok = 0;
589 4         18 $diag .= "STDOUT:\n$stdout\nmatching:\n$expout\nnot expected";
590             }
591 8 100       26 if ( $stderr eq $experr ) {
592 4 100       13 $diag .= "\n" unless ($ok);
593 4         7 $ok = 0;
594 4         16 $diag .= "STDERR:\n$stderr\nmatching:\n$experr\nnot expected";
595             }
596             }
597             elsif ( defined($expout) ) {
598 4         11 $ok = ( $stdout ne $expout );
599 4         17 $diag = "STDOUT:\n$stdout\nmatching:\n$expout\nnot expected";
600             }
601             elsif ( defined($experr) ) {
602 4         13 $ok = ( $stderr ne $experr );
603 4         18 $diag = "STDERR:\n$stderr\nmatching:\n$experr\nnot expected";
604             }
605             else {
606 8 100       182 if ( $stdout eq '' ) {
607 4         7 $ok = 0;
608 4         11 $diag = "STDOUT:\n$stdout\nmatching:\n\nnot expected";
609             }
610 8 100       29 if ( $stderr eq '' ) {
611 4 100       11 $diag .= "\n" unless ($ok);
612 4         10 $ok = 0;
613 4         14 $diag .= "STDERR:\n$stderr\nmatching:\n\nnot expected";
614             }
615             }
616              
617 24 100       302 $Test->ok( $ok, $description ) || $Test->diag($diag);
618              
619 24         11956 return $ok;
620             }
621              
622             =item B
623              
624             =item B
625              
626             output_like ( $coderef, $regex_stdout, $regex_stderr, 'description' );
627             output_like { ... } $regex_stdout, $regex_stderr, 'description';
628             output_unlike( $coderef, $regex_stdout, $regex_stderr, 'description' );
629             output_unlike { ... } $regex_stdout, $regex_stderr, 'description';
630              
631             C and C follow the same principles as C
632             and C except they use a regular expression for matching.
633              
634             C attempts to match C<$regex_stdout> and C<$regex_stderr> against
635             C and C produced by $coderef. The test passes if both match.
636              
637             output_like(sub {print "foo"; print STDERR "bar";},qr/foo/,qr/bar/);
638              
639             The above test is successful.
640              
641             Like C, setting either C<$regex_stdout> or C<$regex_stderr> to
642             C ignores the output to that facility.
643              
644             output_like(sub {print "foo"; print STDERR "bar";},qr/foo/,undef);
645              
646             is the same as
647              
648             stdout_like(sub {print "foo"; print STDERR "bar";},qr/foo/);
649              
650             C test pass if output from C<$coderef> doesn't match
651             C<$regex_stdout> and C<$regex_stderr>.
652              
653             =back
654              
655             =cut
656              
657             sub output_like (&$$;$$) {
658 22     22 1 52111 my $test = shift;
659 22         35 my $expout = shift;
660 22         24 my $experr = shift;
661 22 50       49 my $options = shift if ( ref( $_[0] ) );
662 22         29 my $description = shift;
663              
664 22         39 my ( $stdout, $stderr ) = output_from($test);
665              
666 22         42 my $ok = 1;
667              
668 22 100       47 unless (
669             my $regextest = _chkregex(
670             'output_like_STDERR' => $experr,
671             'output_like_STDOUT' => $expout
672             )
673             )
674             {
675 4         10 return $regextest;
676             }
677              
678 18         24 my $diag;
679 18 100 100     67 if ( defined($experr) && defined($expout) ) {
    100          
    100          
680 9 100       50 unless ( $stdout =~ $expout ) {
681 4         7 $ok = 0;
682 4         14 $diag .= "STDOUT:\n$stdout\ndoesn't match:\n$expout\nas expected";
683             }
684 9 100       34 unless ( $stderr =~ $experr ) {
685 4 100       12 $diag .= "\n" unless ($ok);
686 4         5 $ok = 0;
687 4         11 $diag .= "STDERR:\n$stderr\ndoesn't match:\n$experr\nas expected";
688             }
689             }
690             elsif ( defined($expout) ) {
691 2         12 $ok = ( $stdout =~ $expout );
692 2         9 $diag .= "STDOUT:\n$stdout\ndoesn't match:\n$expout\nas expected";
693             }
694             elsif ( defined($experr) ) {
695 1         6 $ok = ( $stderr =~ $experr );
696 1         5 $diag .= "STDERR:\n$stderr\ndoesn't match:\n$experr\nas expected";
697             }
698             else {
699 6 100       16 unless ( $stdout eq '' ) {
700 2         3 $ok = 0;
701 2         7 $diag .= "STDOUT is:\n$stdout\nnot:\n\nas expected";
702             }
703 6 100       16 unless ( $stderr eq '' ) {
704 4 100       9 $diag .= "\n" unless ($ok);
705 4         7 $ok = 0;
706 4         11 $diag .= "STDERR is:\n$stderr\nnot:\n\nas expected";
707             }
708             }
709              
710 18 100       74 $Test->ok( $ok, $description ) || $Test->diag($diag);
711              
712 18         7121 return $ok;
713             }
714              
715             sub output_unlike (&$$;$$) {
716 16     16 1 38488 my $test = shift;
717 16         28 my $expout = shift;
718 16         25 my $experr = shift;
719 16 50       86 my $options = shift if ( ref( $_[0] ) );
720 16         23 my $description = shift;
721              
722 16         57 my ( $stdout, $stderr ) = output_from($test);
723              
724 16         38 my $ok = 1;
725              
726 16 100       51 unless (
727             my $regextest = _chkregex(
728             'output_unlike_STDERR' => $experr,
729             'output_unlike_STDOUT' => $expout
730             )
731             )
732             {
733 4         12 return $regextest;
734             }
735              
736 12         27 my $diag;
737 12 100 100     61 if ( defined($experr) && defined($expout) ) {
    100          
    50          
738 8 100       45 if ( $stdout =~ $expout ) {
739 4         8 $ok = 0;
740 4         14 $diag .= "STDOUT:\n$stdout\nmatches:\n$expout\nnot expected";
741             }
742 8 100       34 if ( $stderr =~ $experr ) {
743 4 100       12 $diag .= "\n" unless ($ok);
744 4         6 $ok = 0;
745 4         15 $diag .= "STDERR:\n$stderr\nmatches:\n$experr\nnot expected";
746             }
747             }
748             elsif ( defined($expout) ) {
749 2         10 $ok = ( $stdout !~ $expout );
750 2         11 $diag .= "STDOUT:\n$stdout\nmatches:\n$expout\nnot expected";
751             }
752             elsif ( defined($experr) ) {
753 2         10 $ok = ( $stderr !~ $experr );
754 2         8 $diag .= "STDERR:\n$stderr\nmatches:\n$experr\nnot expected";
755             }
756              
757 12 100       47 $Test->ok( $ok, $description ) || $Test->diag($diag);
758              
759 12         5320 return $ok;
760             }
761              
762             =head1 EXPORTS
763              
764             By default, all subroutines are exported by default.
765              
766             =over 4
767              
768             =item * :stdout - the subs with C in the name.
769              
770             =item * :stderr - the subs with C in the name.
771              
772             =item * :functions - the subs with C<_from> at the end.
773              
774             =item * :output - the subs with C in the name.
775              
776             =item * :combined - the subs with C in the name.
777              
778             =item * :tests - everything that outputs TAP
779              
780             =item * :all - everything (which is the same as the default)
781              
782             =back
783              
784             =head1 FUNCTIONS
785              
786             =cut
787              
788             =head2 stdout_from
789              
790             my $stdout = stdout_from($coderef)
791             my $stdout = stdout_from { ... };
792              
793             stdout_from() executes $coderef and captures STDOUT.
794              
795             =cut
796              
797             sub stdout_from (&) {
798 20     20 1 32 my $test = shift;
799              
800             my $stdout = capture_stdout {
801 20     20   15804 select( ( select(STDOUT), $| = 1 )[0] );
802 20         77 $test->()
803 20         472 };
804              
805 20         9990 return $stdout;
806             }
807              
808             =head2 stderr_from
809              
810             my $stderr = stderr_from($coderef)
811             my $stderr = stderr_from { ... };
812              
813             C executes C<$coderef> and captures C.
814              
815             =cut
816              
817             sub stderr_from (&) {
818 19     19 1 1009 my $test = shift;
819              
820             # XXX why is this here and not in output_from or combined_from -- xdg, 2012-05-13
821 0     0   0 local $SIG{__WARN__} = sub { print STDERR @_ }
822 19 50       45 if $] < 5.008;
823              
824             my $stderr = capture_stderr {
825 19     19   13035 select( ( select(STDERR), $| = 1 )[0] );
826 19         75 $test->()
827 19         469 };
828              
829 19         8699 return $stderr;
830             }
831              
832             =head2 output_from
833              
834             my ($stdout, $stderr) = output_from($coderef)
835             my ($stdout, $stderr) = output_from {...};
836              
837             C executes C<$coderef> one time capturing both C and C.
838              
839             =cut
840              
841             sub output_from (&) {
842 86     86 1 117 my $test = shift;
843              
844             my ($stdout, $stderr) = capture {
845 86     86   84829 select( ( select(STDOUT), $| = 1 )[0] );
846 86         393 select( ( select(STDERR), $| = 1 )[0] );
847 86         346 $test->();
848 86         2098 };
849              
850 86         62056 return ( $stdout, $stderr );
851             }
852              
853             =head2 combined_from
854              
855             my $combined = combined_from($coderef);
856             my $combined = combined_from {...};
857              
858             C executes C<$coderef> one time combines C and C, and
859             captures them. C is equivalent to using C<< 2>&1 >> in UNIX.
860              
861             =cut
862              
863             sub combined_from (&) {
864 38     38 1 65 my $test = shift;
865              
866             my $combined = capture_merged {
867 38     38   43708 select( ( select(STDOUT), $| = 1 )[0] );
868 38         156 select( ( select(STDERR), $| = 1 )[0] );
869 38         146 $test->();
870 38         1033 };
871              
872 38         29344 return $combined;
873             }
874              
875             sub _chkregex {
876 76     76   230 my %regexs = @_;
877              
878 76         229 foreach my $test ( keys(%regexs) ) {
879 112 100       246 next unless ( defined( $regexs{$test} ) );
880              
881 93         818 my $usable_regex = $Test->maybe_regex( $regexs{$test} );
882 93 100       2896 unless ( defined($usable_regex) ) {
883 20         82 my $ok = $Test->ok( 0, $test );
884              
885 20         7279 $Test->diag("'$regexs{$test}' doesn't look much like a regex to me.");
886             # unless $ok;
887              
888 20         2348 return $ok;
889             }
890             }
891 56         256 return 1;
892             }
893              
894             =head1 AUTHOR
895              
896             Currently maintained by brian d foy, C.
897              
898             Shawn Sorichetti, C<< >>
899              
900             =head1 SOURCE AVAILABILITY
901              
902             This module is in Github:
903              
904             http://github.com/briandfoy/test-output
905              
906             =head1 BUGS
907              
908             Please report any bugs or feature requests to
909             C, or through the web interface at
910             L. I will be notified, and then you'll automatically
911             be notified of progress on your bug as I make changes.
912              
913             =head1 ACKNOWLEDGEMENTS
914              
915             Thanks to chromatic whose TieOut.pm was the basis for capturing output.
916              
917             Also thanks to rjbs for his help cleaning the documentation, and pushing me to
918             L. (This feature has been removed since it uses none of
919             L's strengths).
920              
921             Thanks to David Wheeler for providing code block support and tests.
922              
923             Thanks to Michael G Schwern for the solution to combining C and C.
924              
925             =head1 COPYRIGHT & LICENSE
926              
927             Copyright 2005-2021 Shawn Sorichetti, All Rights Reserved.
928              
929             This module is licensed under the Artistic License 2.0.
930              
931             =cut
932              
933             1; # End of Test::Output