File Coverage

lib/Test/Builder/Tester.pm
Criterion Covered Total %
statement 109 170 64.1
branch 33 66 50.0
condition 13 39 33.3
subroutine 20 29 68.9
pod 7 7 100.0
total 182 311 58.5


line stmt bran cond sub pod time code
1             package Test::Builder::Tester;
2              
3 14     14   9771 use strict;
  14         67  
  14         618  
4             our $VERSION = '1.302180';
5              
6 14     14   4153 use Test::Builder;
  14         41  
  14         369  
7 14     14   5622 use Symbol;
  14         9089  
  14         857  
8 14     14   99 use Carp;
  14         25  
  14         985  
9              
10             =head1 NAME
11              
12             Test::Builder::Tester - test testsuites that have been built with
13             Test::Builder
14              
15             =head1 SYNOPSIS
16              
17             use Test::Builder::Tester tests => 1;
18             use Test::More;
19              
20             test_out("not ok 1 - foo");
21             test_fail(+1);
22             fail("foo");
23             test_test("fail works");
24              
25             =head1 DESCRIPTION
26              
27             A module that helps you test testing modules that are built with
28             L.
29              
30             The testing system is designed to be used by performing a three step
31             process for each test you wish to test. This process starts with using
32             C and C in advance to declare what the testsuite you
33             are testing will output with L to stdout and stderr.
34              
35             You then can run the test(s) from your test suite that call
36             L. At this point the output of L is
37             safely captured by L rather than being
38             interpreted as real test output.
39              
40             The final stage is to call C that will simply compare what you
41             predeclared to what L actually outputted, and report the
42             results back with a "ok" or "not ok" (with debugging) to the normal
43             output.
44              
45             =cut
46              
47             ####
48             # set up testing
49             ####
50              
51             my $t = Test::Builder->new;
52              
53             ###
54             # make us an exporter
55             ###
56              
57 14     14   85 use Exporter;
  14         27  
  14         31420  
58             our @ISA = qw(Exporter);
59              
60             our @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num);
61              
62             sub import {
63 13     13   115 my $class = shift;
64 13         33 my(@plan) = @_;
65              
66 13         31 my $caller = caller;
67              
68 13         58 $t->exported_to($caller);
69 13         56 $t->plan(@plan);
70              
71 13         26 my @imports = ();
72 13         55 foreach my $idx ( 0 .. $#plan ) {
73 12 50       37 if( $plan[$idx] eq 'import' ) {
74 0         0 @imports = @{ $plan[ $idx + 1 ] };
  0         0  
75 0         0 last;
76             }
77             }
78              
79 13         4087 __PACKAGE__->export_to_level( 1, __PACKAGE__, @imports );
80             }
81              
82             ###
83             # set up file handles
84             ###
85              
86             # create some private file handles
87             my $output_handle = gensym;
88             my $error_handle = gensym;
89              
90             # and tie them to this package
91             my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT";
92             my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR";
93              
94             ####
95             # exported functions
96             ####
97              
98             # for remembering that we're testing and where we're testing at
99             my $testing = 0;
100             my $testing_num;
101             my $original_is_passing;
102              
103             # remembering where the file handles were originally connected
104             my $original_output_handle;
105             my $original_failure_handle;
106             my $original_todo_handle;
107             my $original_formatter;
108              
109             my $original_harness_env;
110              
111             # function that starts testing and redirects the filehandles for now
112             sub _start_testing {
113             # Hack for things that conditioned on Test-Stream being loaded
114 132 50 0 132   344 $INC{'Test/Stream.pm'} ||= 'fake' if $INC{'Test/Moose/More.pm'};
115             # even if we're running under Test::Harness pretend we're not
116             # for now. This needed so Test::Builder doesn't add extra spaces
117 132   100     493 $original_harness_env = $ENV{HARNESS_ACTIVE} || 0;
118 132         543 $ENV{HARNESS_ACTIVE} = 0;
119              
120 132   33     860 my $hub = $t->{Hub} || ($t->{Stack} ? $t->{Stack}->top : Test2::API::test2_stack->top);
121 132         423 $original_formatter = $hub->format;
122 132 50 33     762 unless ($original_formatter && $original_formatter->isa('Test::Builder::Formatter')) {
123 0         0 my $fmt = Test::Builder::Formatter->new;
124 0         0 $hub->format($fmt);
125             }
126              
127             # remember what the handles were set to
128 132         425 $original_output_handle = $t->output();
129 132         392 $original_failure_handle = $t->failure_output();
130 132         540 $original_todo_handle = $t->todo_output();
131              
132             # switch out to our own handles
133 132         459 $t->output($output_handle);
134 132         481 $t->failure_output($error_handle);
135 132         450 $t->todo_output($output_handle);
136              
137             # clear the expected list
138 132         511 $out->reset();
139 132         362 $err->reset();
140              
141             # remember that we're testing
142 132         227 $testing = 1;
143 132         375 $testing_num = $t->current_test;
144 132         462 $t->current_test(0);
145 132         434 $original_is_passing = $t->is_passing;
146 132         524 $t->is_passing(1);
147              
148             # look, we shouldn't do the ending stuff
149 132         457 $t->no_ending(1);
150             }
151              
152             =head2 Functions
153              
154             These are the six methods that are exported as default.
155              
156             =over 4
157              
158             =item test_out
159              
160             =item test_err
161              
162             Procedures for predeclaring the output that your test suite is
163             expected to produce until C is called. These procedures
164             automatically assume that each line terminates with "\n". So
165              
166             test_out("ok 1","ok 2");
167              
168             is the same as
169              
170             test_out("ok 1\nok 2");
171              
172             which is even the same as
173              
174             test_out("ok 1");
175             test_out("ok 2");
176              
177             Once C or C (or C or C) have
178             been called, all further output from L will be
179             captured by L. This means that you will not
180             be able perform further tests to the normal output in the normal way
181             until you call C (well, unless you manually meddle with the
182             output filehandles)
183              
184             =cut
185              
186             sub test_out {
187             # do we need to do any setup?
188 178 100   178 1 6978 _start_testing() unless $testing;
189              
190 178         554 $out->expect(@_);
191             }
192              
193             sub test_err {
194             # do we need to do any setup?
195 58 50   58 1 326 _start_testing() unless $testing;
196              
197 58         119 $err->expect(@_);
198             }
199              
200             =item test_fail
201              
202             Because the standard failure message that L produces
203             whenever a test fails will be a common occurrence in your test error
204             output, and because it has changed between Test::Builder versions, rather
205             than forcing you to call C with the string all the time like
206             so
207              
208             test_err("# Failed test ($0 at line ".line_num(+1).")");
209              
210             C exists as a convenience function that can be called
211             instead. It takes one argument, the offset from the current line that
212             the line that causes the fail is on.
213              
214             test_fail(+1);
215              
216             This means that the example in the synopsis could be rewritten
217             more simply as:
218              
219             test_out("not ok 1 - foo");
220             test_fail(+1);
221             fail("foo");
222             test_test("fail works");
223              
224             =cut
225              
226             sub test_fail {
227             # do we need to do any setup?
228 10 100   10 1 52 _start_testing() unless $testing;
229              
230             # work out what line we should be on
231 10         193 my( $package, $filename, $line ) = caller;
232 10   50     46 $line = $line + ( shift() || 0 ); # prevent warnings
233              
234             # expect that on stderr
235 10         42 $err->expect("# Failed test ($filename at line $line)");
236             }
237              
238             =item test_diag
239              
240             As most of the remaining expected output to the error stream will be
241             created by L's C function, L
242             provides a convenience function C that you can use instead of
243             C.
244              
245             The C function prepends comment hashes and spacing to the
246             start and newlines to the end of the expected output passed to it and
247             adds it to the list of expected error output. So, instead of writing
248              
249             test_err("# Couldn't open file");
250              
251             you can write
252              
253             test_diag("Couldn't open file");
254              
255             Remember that L's diag function will not add newlines to
256             the end of output and test_diag will. So to check
257              
258             Test::Builder->new->diag("foo\n","bar\n");
259              
260             You would do
261              
262             test_diag("foo","bar")
263              
264             without the newlines.
265              
266             =cut
267              
268             sub test_diag {
269             # do we need to do any setup?
270 4 100   4 1 23 _start_testing() unless $testing;
271              
272             # expect the same thing, but prepended with "# "
273 4         5 local $_;
274 4         10 $err->expect( map { "# $_" } @_ );
  6         21  
275             }
276              
277             =item test_test
278              
279             Actually performs the output check testing the tests, comparing the
280             data (with C) that we have captured from L against
281             what was declared with C and C.
282              
283             This takes name/value pairs that effect how the test is run.
284              
285             =over
286              
287             =item title (synonym 'name', 'label')
288              
289             The name of the test that will be displayed after the C or C
290             ok>.
291              
292             =item skip_out
293              
294             Setting this to a true value will cause the test to ignore if the
295             output sent by the test to the output stream does not match that
296             declared with C.
297              
298             =item skip_err
299              
300             Setting this to a true value will cause the test to ignore if the
301             output sent by the test to the error stream does not match that
302             declared with C.
303              
304             =back
305              
306             As a convenience, if only one argument is passed then this argument
307             is assumed to be the name of the test (as in the above examples.)
308              
309             Once C has been run test output will be redirected back to
310             the original filehandles that L was connected to
311             (probably STDOUT and STDERR,) meaning any further tests you run
312             will function normally and cause success/errors for L.
313              
314             =cut
315              
316             sub test_test {
317             # END the hack
318 133 50 33 133 1 1118 delete $INC{'Test/Stream.pm'} if $INC{'Test/Stream.pm'} && $INC{'Test/Stream.pm'} eq 'fake';
319             # decode the arguments as described in the pod
320 133         229 my $mess;
321             my %args;
322 133 100       327 if( @_ == 1 ) {
323 128         251 $mess = shift
324             }
325             else {
326 5         15 %args = @_;
327 5 100       133 $mess = $args{name} if exists( $args{name} );
328 5 100       14 $mess = $args{title} if exists( $args{title} );
329 5 100       10 $mess = $args{label} if exists( $args{label} );
330             }
331              
332             # er, are we testing?
333 133 100       490 croak "Not testing. You must declare output with a test function first."
334             unless $testing;
335              
336              
337 132   33     644 my $hub = $t->{Hub} || Test2::API::test2_stack->top;
338 132         478 $hub->format($original_formatter);
339              
340             # okay, reconnect the test suite back to the saved handles
341 132         449 $t->output($original_output_handle);
342 132         454 $t->failure_output($original_failure_handle);
343 132         449 $t->todo_output($original_todo_handle);
344              
345             # restore the test no, etc, back to the original point
346 132         481 $t->current_test($testing_num);
347 132         276 $testing = 0;
348 132         434 $t->is_passing($original_is_passing);
349              
350             # re-enable the original setting of the harness
351 132         675 $ENV{HARNESS_ACTIVE} = $original_harness_env;
352              
353             # check the output we've stashed
354 132 50 33     596 unless( $t->ok( ( $args{skip_out} || $out->check ) &&
355             ( $args{skip_err} || $err->check ), $mess )
356             )
357             {
358             # print out the diagnostic information about why this
359             # test failed
360              
361 0         0 local $_;
362              
363 0         0 $t->diag( map { "$_\n" } $out->complaint )
364 0 0 0     0 unless $args{skip_out} || $out->check;
365              
366 0         0 $t->diag( map { "$_\n" } $err->complaint )
367 0 0 0     0 unless $args{skip_err} || $err->check;
368             }
369             }
370              
371             =item line_num
372              
373             A utility function that returns the line number that the function was
374             called on. You can pass it an offset which will be added to the
375             result. This is very useful for working out the correct text of
376             diagnostic functions that contain line numbers.
377              
378             Essentially this is the same as the C<__LINE__> macro, but the
379             C idiom is arguably nicer.
380              
381             =cut
382              
383             sub line_num {
384 7     7 1 41 my( $package, $filename, $line ) = caller;
385 7   100     43 return $line + ( shift() || 0 ); # prevent warnings
386             }
387              
388             =back
389              
390             In addition to the six exported functions there exists one
391             function that can only be accessed with a fully qualified function
392             call.
393              
394             =over 4
395              
396             =item color
397              
398             When C is called and the output that your tests generate
399             does not match that which you declared, C will print out
400             debug information showing the two conflicting versions. As this
401             output itself is debug information it can be confusing which part of
402             the output is from C and which was the original output from
403             your original tests. Also, it may be hard to spot things like
404             extraneous whitespace at the end of lines that may cause your test to
405             fail even though the output looks similar.
406              
407             To assist you C can colour the background of the debug
408             information to disambiguate the different types of output. The debug
409             output will have its background coloured green and red. The green
410             part represents the text which is the same between the executed and
411             actual output, the red shows which part differs.
412              
413             The C function determines if colouring should occur or not.
414             Passing it a true or false value will enable or disable colouring
415             respectively, and the function called with no argument will return the
416             current setting.
417              
418             To enable colouring from the command line, you can use the
419             L module like so:
420              
421             perl -Mlib=Text::Builder::Tester::Color test.t
422              
423             Or by including the L module directly in
424             the PERL5LIB.
425              
426             =cut
427              
428             my $color;
429              
430             sub color {
431 0 0   0 1 0 $color = shift if @_;
432 0         0 $color;
433             }
434              
435             =back
436              
437             =head1 BUGS
438              
439             Test::Builder::Tester does not handle plans well. It has never done anything
440             special with plans. This means that plans from outside Test::Builder::Tester
441             will effect Test::Builder::Tester, worse plans when using Test::Builder::Tester
442             will effect overall testing. At this point there are no plans to fix this bug
443             as people have come to depend on it, and Test::Builder::Tester is now
444             discouraged in favor of C. See
445             L
446              
447             Calls C<< Test::Builder->no_ending >> turning off the ending tests.
448             This is needed as otherwise it will trip out because we've run more
449             tests than we strictly should have and it'll register any failures we
450             had that we were testing for as real failures.
451              
452             The color function doesn't work unless L is
453             compatible with your terminal. Additionally, L
454             must be installed on windows platforms for color output.
455              
456             Bugs (and requests for new features) can be reported to the author
457             though GitHub:
458             L
459              
460             =head1 AUTHOR
461              
462             Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004.
463              
464             Some code taken from L and L, written by
465             Michael G Schwern Eschwern@pobox.comE. Hence, those parts
466             Copyright Micheal G Schwern 2001. Used and distributed with
467             permission.
468              
469             This program is free software; you can redistribute it
470             and/or modify it under the same terms as Perl itself.
471              
472             =head1 MAINTAINERS
473              
474             =over 4
475              
476             =item Chad Granum Eexodist@cpan.orgE
477              
478             =back
479              
480             =head1 NOTES
481              
482             Thanks to Richard Clamp Erichardc@unixbeard.netE for letting
483             me use his testing system to try this module out on.
484              
485             =head1 SEE ALSO
486              
487             L, L, L.
488              
489             =cut
490              
491             1;
492              
493             ####################################################################
494             # Helper class that is used to remember expected and received data
495              
496             package Test::Builder::Tester::Tie;
497              
498             ##
499             # add line(s) to be expected
500              
501             sub expect {
502 265     265   468 my $self = shift;
503              
504 265         703 my @checks = @_;
505 265         474 foreach my $check (@checks) {
506 1359         2373 $check = $self->_account_for_subtest($check);
507 1359         2451 $check = $self->_translate_Failed_check($check);
508 1359 100       1810 push @{ $self->{wanted} }, ref $check ? $check : "$check\n";
  1359         4438  
509             }
510             }
511              
512             sub _account_for_subtest {
513 1359     1359   2238 my( $self, $check ) = @_;
514              
515 1359         2983 my $hub = $t->{Stack}->top;
516 1359 100       4067 my $nesting = $hub->isa('Test2::Hub::Subtest') ? $hub->nested : 0;
517 1359 100       3786 return ref($check) ? $check : (' ' x $nesting) . $check;
518             }
519              
520             sub _translate_Failed_check {
521 1359     1359   2172 my( $self, $check ) = @_;
522              
523 1359 100       3052 if( $check =~ /\A(.*)# (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) {
524 16         138 $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/";
525             }
526              
527 1359         2351 return $check;
528             }
529              
530             ##
531             # return true iff the expected data matches the got data
532              
533             sub check {
534 288     288   505 my $self = shift;
535              
536             # turn off warnings as these might be undef
537 288         859 local $^W = 0;
538              
539 288         440 my @checks = @{ $self->{wanted} };
  288         886  
540 288         557 my $got = $self->{got};
541 288         546 foreach my $check (@checks) {
542 1357 100 100     6041 $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check );
543 1357 50       16480 return 0 unless $got =~ s/^$check//;
544             }
545              
546 288         2005 return length $got == 0;
547             }
548              
549             ##
550             # a complaint message about the inputs not matching (to be
551             # used for debugging messages)
552              
553             sub complaint {
554 0     0   0 my $self = shift;
555 0         0 my $type = $self->type;
556 0         0 my $got = $self->got;
557 0         0 my $wanted = join '', @{ $self->wanted };
  0         0  
558              
559             # are we running in colour mode?
560 0 0       0 if(Test::Builder::Tester::color) {
561             # get color
562 0         0 eval { require Term::ANSIColor };
  0         0  
563 0 0       0 unless($@) {
564 0 0       0 eval { require Win32::Console::ANSI } if 'MSWin32' eq $^O; # support color on windows platforms
  0         0  
565              
566             # colours
567              
568 0         0 my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green");
569 0         0 my $red = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_red");
570 0         0 my $reset = Term::ANSIColor::color("reset");
571              
572             # work out where the two strings start to differ
573 0         0 my $char = 0;
574 0         0 $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 );
575              
576             # get the start string and the two end strings
577 0         0 my $start = $green . substr( $wanted, 0, $char );
578 0         0 my $gotend = $red . substr( $got, $char ) . $reset;
579 0         0 my $wantedend = $red . substr( $wanted, $char ) . $reset;
580              
581             # make the start turn green on and off
582 0         0 $start =~ s/\n/$reset\n$green/g;
583              
584             # make the ends turn red on and off
585 0         0 $gotend =~ s/\n/$reset\n$red/g;
586 0         0 $wantedend =~ s/\n/$reset\n$red/g;
587              
588             # rebuild the strings
589 0         0 $got = $start . $gotend;
590 0         0 $wanted = $start . $wantedend;
591             }
592             }
593              
594 0         0 my @got = split "\n", $got;
595 0         0 my @wanted = split "\n", $wanted;
596              
597 0         0 $got = "";
598 0         0 $wanted = "";
599              
600 0   0     0 while (@got || @wanted) {
601 0   0     0 my $g = shift @got || "";
602 0   0     0 my $w = shift @wanted || "";
603 0 0       0 if ($g ne $w) {
604 0 0       0 if($g =~ s/(\s+)$/ |> /g) {
605 0 0       0 $g .= ($_ eq ' ' ? '_' : '\t') for split '', $1;
606             }
607 0 0       0 if($w =~ s/(\s+)$/ |> /g) {
608 0 0       0 $w .= ($_ eq ' ' ? '_' : '\t') for split '', $1;
609             }
610 0         0 $g = "> $g";
611 0         0 $w = "> $w";
612             }
613             else {
614 0         0 $g = " $g";
615 0         0 $w = " $w";
616             }
617 0 0       0 $got = $got ? "$got\n$g" : $g;
618 0 0       0 $wanted = $wanted ? "$wanted\n$w" : $w;
619             }
620              
621 0         0 return "$type is:\n" . "$got\nnot:\n$wanted\nas expected";
622             }
623              
624             ##
625             # forget all expected and got data
626              
627             sub reset {
628 322     322   561 my $self = shift;
629             %$self = (
630             type => $self->{type},
631 322         1571 got => '',
632             wanted => [],
633             );
634             }
635              
636             sub got {
637 0     0   0 my $self = shift;
638 0         0 return $self->{got};
639             }
640              
641             sub wanted {
642 0     0   0 my $self = shift;
643 0         0 return $self->{wanted};
644             }
645              
646             sub type {
647 0     0   0 my $self = shift;
648 0         0 return $self->{type};
649             }
650              
651             ###
652             # tie interface
653             ###
654              
655             sub PRINT {
656 1049     1049   1824 my $self = shift;
657 1049         4438 $self->{got} .= join '', @_;
658             }
659              
660             sub TIEHANDLE {
661 32     32   195 my( $class, $type ) = @_;
662              
663 32         92 my $self = bless { type => $type }, $class;
664              
665 32         99 $self->reset;
666              
667 32         78 return $self;
668             }
669              
670       0     sub READ { }
671       0     sub READLINE { }
672       0     sub GETC { }
673       0     sub FILENO { }
674              
675             1;