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