Synch with CPAN Test-Simple 1.302140.
[perl.git] / cpan / Test-Simple / lib / Test / Builder / Tester.pm
1 package Test::Builder::Tester;
2
3 use strict;
4 our $VERSION = '1.302140';
5
6 use Test::Builder;
7 use Symbol;
8 use Carp;
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<Test::Builder>.
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<test_out> and C<test_err> in advance to declare what the testsuite you
33 are testing will output with L<Test::Builder> to stdout and stderr.
34
35 You then can run the test(s) from your test suite that call
36 L<Test::Builder>.  At this point the output of L<Test::Builder> is
37 safely captured by L<Test::Builder::Tester> rather than being
38 interpreted as real test output.
39
40 The final stage is to call C<test_test> that will simply compare what you
41 predeclared to what L<Test::Builder> 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 use Exporter;
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     my $class = shift;
64     my(@plan) = @_;
65
66     my $caller = caller;
67
68     $t->exported_to($caller);
69     $t->plan(@plan);
70
71     my @imports = ();
72     foreach my $idx ( 0 .. $#plan ) {
73         if( $plan[$idx] eq 'import' ) {
74             @imports = @{ $plan[ $idx + 1 ] };
75             last;
76         }
77     }
78
79     __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     $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     $original_harness_env = $ENV{HARNESS_ACTIVE} || 0;
118     $ENV{HARNESS_ACTIVE} = 0;
119
120     my $hub = $t->{Hub} || ($t->{Stack} ? $t->{Stack}->top : Test2::API::test2_stack->top);
121     $original_formatter = $hub->format;
122     unless ($original_formatter && $original_formatter->isa('Test::Builder::Formatter')) {
123         my $fmt = Test::Builder::Formatter->new;
124         $hub->format($fmt);
125     }
126
127     # remember what the handles were set to
128     $original_output_handle  = $t->output();
129     $original_failure_handle = $t->failure_output();
130     $original_todo_handle    = $t->todo_output();
131
132     # switch out to our own handles
133     $t->output($output_handle);
134     $t->failure_output($error_handle);
135     $t->todo_output($output_handle);
136
137     # clear the expected list
138     $out->reset();
139     $err->reset();
140
141     # remember that we're testing
142     $testing     = 1;
143     $testing_num = $t->current_test;
144     $t->current_test(0);
145     $original_is_passing  = $t->is_passing;
146     $t->is_passing(1);
147
148     # look, we shouldn't do the ending stuff
149     $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<test_test> 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<test_out> or C<test_err> (or C<test_fail> or C<test_diag>) have
178 been called, all further output from L<Test::Builder> will be
179 captured by L<Test::Builder::Tester>.  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<test_test> (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     _start_testing() unless $testing;
189
190     $out->expect(@_);
191 }
192
193 sub test_err {
194     # do we need to do any setup?
195     _start_testing() unless $testing;
196
197     $err->expect(@_);
198 }
199
200 =item test_fail
201
202 Because the standard failure message that L<Test::Builder> 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<test_err> with the string all the time like
206 so
207
208     test_err("# Failed test ($0 at line ".line_num(+1).")");
209
210 C<test_fail> 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     _start_testing() unless $testing;
229
230     # work out what line we should be on
231     my( $package, $filename, $line ) = caller;
232     $line = $line + ( shift() || 0 );    # prevent warnings
233
234     # expect that on stderr
235     $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<Test::Builder>'s C<diag> function, L<Test::Builder::Tester>
242 provides a convenience function C<test_diag> that you can use instead of
243 C<test_err>.
244
245 The C<test_diag> 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<Test::Builder>'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     _start_testing() unless $testing;
271
272     # expect the same thing, but prepended with "#     "
273     local $_;
274     $err->expect( map { "# $_" } @_ );
275 }
276
277 =item test_test
278
279 Actually performs the output check testing the tests, comparing the
280 data (with C<eq>) that we have captured from L<Test::Builder> against
281 what was declared with C<test_out> and C<test_err>.
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<ok> or C<not
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<test_out>.
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<test_err>.
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<test_test> has been run test output will be redirected back to
310 the original filehandles that L<Test::Builder> was connected to
311 (probably STDOUT and STDERR,) meaning any further tests you run
312 will function normally and cause success/errors for L<Test::Harness>.
313
314 =cut
315
316 sub test_test {
317     # END the hack
318     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     my $mess;
321     my %args;
322     if( @_ == 1 ) {
323         $mess = shift
324     }
325     else {
326         %args = @_;
327         $mess = $args{name} if exists( $args{name} );
328         $mess = $args{title} if exists( $args{title} );
329         $mess = $args{label} if exists( $args{label} );
330     }
331
332     # er, are we testing?
333     croak "Not testing.  You must declare output with a test function first."
334       unless $testing;
335
336
337     my $hub = $t->{Hub} || Test2::API::test2_stack->top;
338     $hub->format($original_formatter);
339
340     # okay, reconnect the test suite back to the saved handles
341     $t->output($original_output_handle);
342     $t->failure_output($original_failure_handle);
343     $t->todo_output($original_todo_handle);
344
345     # restore the test no, etc, back to the original point
346     $t->current_test($testing_num);
347     $testing = 0;
348     $t->is_passing($original_is_passing);
349
350     # re-enable the original setting of the harness
351     $ENV{HARNESS_ACTIVE} = $original_harness_env;
352
353     # check the output we've stashed
354     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         local $_;
362
363         $t->diag( map { "$_\n" } $out->complaint )
364           unless $args{skip_out} || $out->check;
365
366         $t->diag( map { "$_\n" } $err->complaint )
367           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<line_num(+3)> idiom is arguably nicer.
380
381 =cut
382
383 sub line_num {
384     my( $package, $filename, $line ) = caller;
385     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<test_test> is called and the output that your tests generate
399 does not match that which you declared, C<test_test> 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<test_test> 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<test_test> 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<color> 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<Text::Builder::Tester::Color> module like so:
420
421    perl -Mlib=Text::Builder::Tester::Color test.t
422
423 Or by including the L<Test::Builder::Tester::Color> module directly in
424 the PERL5LIB.
425
426 =cut
427
428 my $color;
429
430 sub color {
431     $color = shift if @_;
432     $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<Test2::API::intercept()>. See
445 L<https://github.com/Test-More/test-more/issues/667>
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<Term::ANSIColor> is
453 compatible with your terminal. Additionally, L<Win32::Console::ANSI>
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<https://github.com/Test-More/test-more/issues>
459
460 =head1 AUTHOR
461
462 Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
463
464 Some code taken from L<Test::More> and L<Test::Catch>, written by
465 Michael G Schwern E<lt>schwern@pobox.comE<gt>.  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 E<lt>exodist@cpan.orgE<gt>
477
478 =back
479
480 =head1 NOTES
481
482 Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting
483 me use his testing system to try this module out on.
484
485 =head1 SEE ALSO
486
487 L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>.
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     my $self = shift;
503
504     my @checks = @_;
505     foreach my $check (@checks) {
506         $check = $self->_account_for_subtest($check);
507         $check = $self->_translate_Failed_check($check);
508         push @{ $self->{wanted} }, ref $check ? $check : "$check\n";
509     }
510 }
511
512 sub _account_for_subtest {
513     my( $self, $check ) = @_;
514
515     my $hub = $t->{Stack}->top;
516     my $nesting = $hub->isa('Test2::Hub::Subtest') ? $hub->nested : 0;
517     return ref($check) ? $check : ('    ' x $nesting) . $check;
518 }
519
520 sub _translate_Failed_check {
521     my( $self, $check ) = @_;
522
523     if( $check =~ /\A(.*)#     (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) {
524         $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/";
525     }
526
527     return $check;
528 }
529
530 ##
531 # return true iff the expected data matches the got data
532
533 sub check {
534     my $self = shift;
535
536     # turn off warnings as these might be undef
537     local $^W = 0;
538
539     my @checks = @{ $self->{wanted} };
540     my $got    = $self->{got};
541     foreach my $check (@checks) {
542         $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check );
543         return 0 unless $got =~ s/^$check//;
544     }
545
546     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     my $self   = shift;
555     my $type   = $self->type;
556     my $got    = $self->got;
557     my $wanted = join '', @{ $self->wanted };
558
559     # are we running in colour mode?
560     if(Test::Builder::Tester::color) {
561         # get color
562         eval { require Term::ANSIColor };
563         unless($@) {
564             eval { require Win32::Console::ANSI } if 'MSWin32' eq $^O;  # support color on windows platforms
565
566             # colours
567
568             my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green");
569             my $red   = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_red");
570             my $reset = Term::ANSIColor::color("reset");
571
572             # work out where the two strings start to differ
573             my $char = 0;
574             $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 );
575
576             # get the start string and the two end strings
577             my $start = $green . substr( $wanted, 0, $char );
578             my $gotend    = $red . substr( $got,    $char ) . $reset;
579             my $wantedend = $red . substr( $wanted, $char ) . $reset;
580
581             # make the start turn green on and off
582             $start =~ s/\n/$reset\n$green/g;
583
584             # make the ends turn red on and off
585             $gotend    =~ s/\n/$reset\n$red/g;
586             $wantedend =~ s/\n/$reset\n$red/g;
587
588             # rebuild the strings
589             $got    = $start . $gotend;
590             $wanted = $start . $wantedend;
591         }
592     }
593
594     my @got = split "\n", $got;
595     my @wanted = split "\n", $wanted;
596
597     $got = "";
598     $wanted = "";
599
600     while (@got || @wanted) {
601         my $g = shift @got    || "";
602         my $w = shift @wanted || "";
603         if ($g ne $w) {
604             if($g =~ s/(\s+)$/    |> /g) {
605                 $g .= ($_ eq ' ' ? '_' : '\t') for split '', $1;
606             }
607             if($w =~ s/(\s+)$/    |> /g) {
608                 $w .= ($_ eq ' ' ? '_' : '\t') for split '', $1;
609             }
610             $g = "> $g";
611             $w = "> $w";
612         }
613         else {
614             $g = "  $g";
615             $w = "  $w";
616         }
617         $got = $got ? "$got\n$g" : $g;
618         $wanted = $wanted ? "$wanted\n$w" : $w;
619     }
620
621     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     my $self = shift;
629     %$self = (
630         type   => $self->{type},
631         got    => '',
632         wanted => [],
633     );
634 }
635
636 sub got {
637     my $self = shift;
638     return $self->{got};
639 }
640
641 sub wanted {
642     my $self = shift;
643     return $self->{wanted};
644 }
645
646 sub type {
647     my $self = shift;
648     return $self->{type};
649 }
650
651 ###
652 # tie interface
653 ###
654
655 sub PRINT {
656     my $self = shift;
657     $self->{got} .= join '', @_;
658 }
659
660 sub TIEHANDLE {
661     my( $class, $type ) = @_;
662
663     my $self = bless { type => $type }, $class;
664
665     $self->reset;
666
667     return $self;
668 }
669
670 sub READ     { }
671 sub READLINE { }
672 sub GETC     { }
673 sub FILENO   { }
674
675 1;