This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
5128be9d90859c7fe913de6fd959a183fbb17451
[perl5.git] / cpan / Test-Simple / lib / Test / Builder / Tester.pm
1 package Test::Builder::Tester;
2
3 use strict;
4 our $VERSION = "1.23_003";
5
6 use Test::Builder 0.98;
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 B<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 B<Test::Builder> to stdout and stderr.
34
35 You then can run the test(s) from your test suite that call
36 B<Test::Builder>.  At this point the output of B<Test::Builder> is
37 safely captured by B<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 B<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
108 my $original_harness_env;
109
110 # function that starts testing and redirects the filehandles for now
111 sub _start_testing {
112     # even if we're running under Test::Harness pretend we're not
113     # for now.  This needed so Test::Builder doesn't add extra spaces
114     $original_harness_env = $ENV{HARNESS_ACTIVE} || 0;
115     $ENV{HARNESS_ACTIVE} = 0;
116
117     # remember what the handles were set to
118     $original_output_handle  = $t->output();
119     $original_failure_handle = $t->failure_output();
120     $original_todo_handle    = $t->todo_output();
121
122     # switch out to our own handles
123     $t->output($output_handle);
124     $t->failure_output($error_handle);
125     $t->todo_output($output_handle);
126
127     # clear the expected list
128     $out->reset();
129     $err->reset();
130
131     # remember that we're testing
132     $testing     = 1;
133     $testing_num = $t->current_test;
134     $t->current_test(0);
135     $original_is_passing  = $t->is_passing;
136     $t->is_passing(1);
137
138     # look, we shouldn't do the ending stuff
139     $t->no_ending(1);
140 }
141
142 =head2 Functions
143
144 These are the six methods that are exported as default.
145
146 =over 4
147
148 =item test_out
149
150 =item test_err
151
152 Procedures for predeclaring the output that your test suite is
153 expected to produce until C<test_test> is called.  These procedures
154 automatically assume that each line terminates with "\n".  So
155
156    test_out("ok 1","ok 2");
157
158 is the same as
159
160    test_out("ok 1\nok 2");
161
162 which is even the same as
163
164    test_out("ok 1");
165    test_out("ok 2");
166
167 Once C<test_out> or C<test_err> (or C<test_fail> or C<test_diag>) have
168 been called, all further output from B<Test::Builder> will be
169 captured by B<Test::Builder::Tester>.  This means that you will not
170 be able perform further tests to the normal output in the normal way
171 until you call C<test_test> (well, unless you manually meddle with the
172 output filehandles)
173
174 =cut
175
176 sub test_out {
177     # do we need to do any setup?
178     _start_testing() unless $testing;
179
180     $out->expect(@_);
181 }
182
183 sub test_err {
184     # do we need to do any setup?
185     _start_testing() unless $testing;
186
187     $err->expect(@_);
188 }
189
190 =item test_fail
191
192 Because the standard failure message that B<Test::Builder> produces
193 whenever a test fails will be a common occurrence in your test error
194 output, and because it has changed between Test::Builder versions, rather
195 than forcing you to call C<test_err> with the string all the time like
196 so
197
198     test_err("# Failed test ($0 at line ".line_num(+1).")");
199
200 C<test_fail> exists as a convenience function that can be called
201 instead.  It takes one argument, the offset from the current line that
202 the line that causes the fail is on.
203
204     test_fail(+1);
205
206 This means that the example in the synopsis could be rewritten
207 more simply as:
208
209    test_out("not ok 1 - foo");
210    test_fail(+1);
211    fail("foo");
212    test_test("fail works");
213
214 =cut
215
216 sub test_fail {
217     # do we need to do any setup?
218     _start_testing() unless $testing;
219
220     # work out what line we should be on
221     my( $package, $filename, $line ) = caller;
222     $line = $line + ( shift() || 0 );    # prevent warnings
223
224     # expect that on stderr
225     $err->expect("#     Failed test ($filename at line $line)");
226 }
227
228 =item test_diag
229
230 As most of the remaining expected output to the error stream will be
231 created by Test::Builder's C<diag> function, B<Test::Builder::Tester>
232 provides a convenience function C<test_diag> that you can use instead of
233 C<test_err>.
234
235 The C<test_diag> function prepends comment hashes and spacing to the
236 start and newlines to the end of the expected output passed to it and
237 adds it to the list of expected error output.  So, instead of writing
238
239    test_err("# Couldn't open file");
240
241 you can write
242
243    test_diag("Couldn't open file");
244
245 Remember that B<Test::Builder>'s diag function will not add newlines to
246 the end of output and test_diag will. So to check
247
248    Test::Builder->new->diag("foo\n","bar\n");
249
250 You would do
251
252   test_diag("foo","bar")
253
254 without the newlines.
255
256 =cut
257
258 sub test_diag {
259     # do we need to do any setup?
260     _start_testing() unless $testing;
261
262     # expect the same thing, but prepended with "#     "
263     local $_;
264     $err->expect( map { "# $_" } @_ );
265 }
266
267 =item test_test
268
269 Actually performs the output check testing the tests, comparing the
270 data (with C<eq>) that we have captured from B<Test::Builder> against
271 what was declared with C<test_out> and C<test_err>.
272
273 This takes name/value pairs that effect how the test is run.
274
275 =over
276
277 =item title (synonym 'name', 'label')
278
279 The name of the test that will be displayed after the C<ok> or C<not
280 ok>.
281
282 =item skip_out
283
284 Setting this to a true value will cause the test to ignore if the
285 output sent by the test to the output stream does not match that
286 declared with C<test_out>.
287
288 =item skip_err
289
290 Setting this to a true value will cause the test to ignore if the
291 output sent by the test to the error stream does not match that
292 declared with C<test_err>.
293
294 =back
295
296 As a convenience, if only one argument is passed then this argument
297 is assumed to be the name of the test (as in the above examples.)
298
299 Once C<test_test> has been run test output will be redirected back to
300 the original filehandles that B<Test::Builder> was connected to
301 (probably STDOUT and STDERR,) meaning any further tests you run
302 will function normally and cause success/errors for B<Test::Harness>.
303
304 =cut
305
306 sub test_test {
307     # decode the arguments as described in the pod
308     my $mess;
309     my %args;
310     if( @_ == 1 ) {
311         $mess = shift
312     }
313     else {
314         %args = @_;
315         $mess = $args{name} if exists( $args{name} );
316         $mess = $args{title} if exists( $args{title} );
317         $mess = $args{label} if exists( $args{label} );
318     }
319
320     # er, are we testing?
321     croak "Not testing.  You must declare output with a test function first."
322       unless $testing;
323
324     # okay, reconnect the test suite back to the saved handles
325     $t->output($original_output_handle);
326     $t->failure_output($original_failure_handle);
327     $t->todo_output($original_todo_handle);
328
329     # restore the test no, etc, back to the original point
330     $t->current_test($testing_num);
331     $testing = 0;
332     $t->is_passing($original_is_passing);
333
334     # re-enable the original setting of the harness
335     $ENV{HARNESS_ACTIVE} = $original_harness_env;
336
337     # check the output we've stashed
338     unless( $t->ok( ( $args{skip_out} || $out->check ) &&
339                     ( $args{skip_err} || $err->check ), $mess ) 
340     )
341     {
342         # print out the diagnostic information about why this
343         # test failed
344
345         local $_;
346
347         $t->diag( map { "$_\n" } $out->complaint )
348           unless $args{skip_out} || $out->check;
349
350         $t->diag( map { "$_\n" } $err->complaint )
351           unless $args{skip_err} || $err->check;
352     }
353 }
354
355 =item line_num
356
357 A utility function that returns the line number that the function was
358 called on.  You can pass it an offset which will be added to the
359 result.  This is very useful for working out the correct text of
360 diagnostic functions that contain line numbers.
361
362 Essentially this is the same as the C<__LINE__> macro, but the
363 C<line_num(+3)> idiom is arguably nicer.
364
365 =cut
366
367 sub line_num {
368     my( $package, $filename, $line ) = caller;
369     return $line + ( shift() || 0 );    # prevent warnings
370 }
371
372 =back
373
374 In addition to the six exported functions there exists one
375 function that can only be accessed with a fully qualified function
376 call.
377
378 =over 4
379
380 =item color
381
382 When C<test_test> is called and the output that your tests generate
383 does not match that which you declared, C<test_test> will print out
384 debug information showing the two conflicting versions.  As this
385 output itself is debug information it can be confusing which part of
386 the output is from C<test_test> and which was the original output from
387 your original tests.  Also, it may be hard to spot things like
388 extraneous whitespace at the end of lines that may cause your test to
389 fail even though the output looks similar.
390
391 To assist you C<test_test> can colour the background of the debug
392 information to disambiguate the different types of output. The debug
393 output will have its background coloured green and red.  The green
394 part represents the text which is the same between the executed and
395 actual output, the red shows which part differs.
396
397 The C<color> function determines if colouring should occur or not.
398 Passing it a true or false value will enable or disable colouring
399 respectively, and the function called with no argument will return the
400 current setting.
401
402 To enable colouring from the command line, you can use the
403 B<Text::Builder::Tester::Color> module like so:
404
405    perl -Mlib=Text::Builder::Tester::Color test.t
406
407 Or by including the B<Test::Builder::Tester::Color> module directly in
408 the PERL5LIB.
409
410 =cut
411
412 my $color;
413
414 sub color {
415     $color = shift if @_;
416     $color;
417 }
418
419 =back
420
421 =head1 BUGS
422
423 Calls C<<Test::Builder->no_ending>> turning off the ending tests.
424 This is needed as otherwise it will trip out because we've run more
425 tests than we strictly should have and it'll register any failures we
426 had that we were testing for as real failures.
427
428 The color function doesn't work unless B<Term::ANSIColor> is
429 compatible with your terminal.
430
431 Bugs (and requests for new features) can be reported to the author
432 though the CPAN RT system:
433 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Builder-Tester>
434
435 =head1 AUTHOR
436
437 Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
438
439 Some code taken from B<Test::More> and B<Test::Catch>, written by
440 Michael G Schwern E<lt>schwern@pobox.comE<gt>.  Hence, those parts
441 Copyright Micheal G Schwern 2001.  Used and distributed with
442 permission.
443
444 This program is free software; you can redistribute it
445 and/or modify it under the same terms as Perl itself.
446
447 =head1 MAINTAINERS
448
449 =over 4
450
451 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
452
453 =back
454
455 =head1 NOTES
456
457 Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting
458 me use his testing system to try this module out on.
459
460 =head1 SEE ALSO
461
462 L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>.
463
464 =cut
465
466 1;
467
468 ####################################################################
469 # Helper class that is used to remember expected and received data
470
471 package Test::Builder::Tester::Tie;
472
473 ##
474 # add line(s) to be expected
475
476 sub expect {
477     my $self = shift;
478
479     my @checks = @_;
480     foreach my $check (@checks) {
481         $check = $self->_account_for_subtest($check);
482         $check = $self->_translate_Failed_check($check);
483         push @{ $self->{wanted} }, ref $check ? $check : "$check\n";
484     }
485 }
486
487 sub _account_for_subtest {
488     my( $self, $check ) = @_;
489
490     # Since we ship with Test::Builder, calling a private method is safe...ish.
491     return ref($check) ? $check : $t->_indent . $check;
492 }
493
494 sub _translate_Failed_check {
495     my( $self, $check ) = @_;
496
497     if( $check =~ /\A(.*)#     (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) {
498         $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/";
499     }
500
501     return $check;
502 }
503
504 ##
505 # return true iff the expected data matches the got data
506
507 sub check {
508     my $self = shift;
509
510     # turn off warnings as these might be undef
511     local $^W = 0;
512
513     my @checks = @{ $self->{wanted} };
514     my $got    = $self->{got};
515     foreach my $check (@checks) {
516         $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check );
517         return 0 unless $got =~ s/^$check//;
518     }
519
520     return length $got == 0;
521 }
522
523 ##
524 # a complaint message about the inputs not matching (to be
525 # used for debugging messages)
526
527 sub complaint {
528     my $self   = shift;
529     my $type   = $self->type;
530     my $got    = $self->got;
531     my $wanted = join '', @{ $self->wanted };
532
533     # are we running in colour mode?
534     if(Test::Builder::Tester::color) {
535         # get color
536         eval { require Term::ANSIColor };
537         unless($@) {
538             # colours
539
540             my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green");
541             my $red   = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_red");
542             my $reset = Term::ANSIColor::color("reset");
543
544             # work out where the two strings start to differ
545             my $char = 0;
546             $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 );
547
548             # get the start string and the two end strings
549             my $start = $green . substr( $wanted, 0, $char );
550             my $gotend    = $red . substr( $got,    $char ) . $reset;
551             my $wantedend = $red . substr( $wanted, $char ) . $reset;
552
553             # make the start turn green on and off
554             $start =~ s/\n/$reset\n$green/g;
555
556             # make the ends turn red on and off
557             $gotend    =~ s/\n/$reset\n$red/g;
558             $wantedend =~ s/\n/$reset\n$red/g;
559
560             # rebuild the strings
561             $got    = $start . $gotend;
562             $wanted = $start . $wantedend;
563         }
564     }
565
566     return "$type is:\n" . "$got\nnot:\n$wanted\nas expected";
567 }
568
569 ##
570 # forget all expected and got data
571
572 sub reset {
573     my $self = shift;
574     %$self = (
575         type   => $self->{type},
576         got    => '',
577         wanted => [],
578     );
579 }
580
581 sub got {
582     my $self = shift;
583     return $self->{got};
584 }
585
586 sub wanted {
587     my $self = shift;
588     return $self->{wanted};
589 }
590
591 sub type {
592     my $self = shift;
593     return $self->{type};
594 }
595
596 ###
597 # tie interface
598 ###
599
600 sub PRINT {
601     my $self = shift;
602     $self->{got} .= join '', @_;
603 }
604
605 sub TIEHANDLE {
606     my( $class, $type ) = @_;
607
608     my $self = bless { type => $type }, $class;
609
610     $self->reset;
611
612     return $self;
613 }
614
615 sub READ     { }
616 sub READLINE { }
617 sub GETC     { }
618 sub FILENO   { }
619
620 1;