1 package Test::Builder::Tester;
4 use vars qw(@EXPORT $VERSION @ISA);
13 Test::Builder::Tester - test testsuites that have been built with
18 use Test::Builder::Tester tests => 1;
21 test_out("not ok 1 - foo");
24 test_test("fail works");
28 A module that helps you test testing modules that are built with
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.
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.
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
52 my $t = Test::Builder->new;
61 @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num);
63 # _export_to_level and import stolen directly from Test::More. I am
64 # the king of cargo cult programming ;-)
66 # 5.004's Exporter doesn't have export_to_level.
71 (undef) = shift; # XXX redundant arg
72 my $callpkg = caller($level);
73 $pkg->export($callpkg, @_);
82 $t->exported_to($caller);
86 foreach my $idx (0..$#plan) {
87 if( $plan[$idx] eq 'import' ) {
88 @imports = @{$plan[$idx+1]};
93 __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
100 # create some private file handles
101 my $output_handle = gensym;
102 my $error_handle = gensym;
104 # and tie them to this package
105 my $out = tie *$output_handle, "Test::Tester::Tie", "STDOUT";
106 my $err = tie *$error_handle, "Test::Tester::Tie", "STDERR";
112 # for remembering that we're testing and where we're testing at
116 # remembering where the file handles were originally connected
117 my $original_output_handle;
118 my $original_failure_handle;
119 my $original_todo_handle;
121 my $original_test_number;
122 my $original_harness_state;
124 my $original_harness_env;
126 # function that starts testing and redirects the filehandles for now
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;
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();
139 # switch out to our own handles
140 $t->output($output_handle);
141 $t->failure_output($error_handle);
142 $t->todo_output($error_handle);
144 # clear the expected list
148 # remeber that we're testing
150 $testing_num = $t->current_test;
153 # look, we shouldn't do the ending stuff
159 These are the six methods that are exported as default.
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
171 test_out("ok 1","ok 2");
175 test_out("ok 1\nok 2");
177 which is even the same as
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
193 # do we need to do any setup?
194 _start_testing() unless $testing;
201 # do we need to do any setup?
202 _start_testing() unless $testing;
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
215 test_err("# Failed test ($0 at line ".line_num(+1).")");
217 C<test_fail> exists as a convenience method 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.
223 This means that the example in the synopsis could be rewritten
226 test_out("not ok 1 - foo");
229 test_test("fail works");
235 # do we need to do any setup?
236 _start_testing() unless $testing;
238 # work out what line we should be on
239 my ($package, $filename, $line) = caller;
240 $line = $line + (shift() || 0); # prevent warnings
242 # expect that on stderr
243 $err->expect("# Failed test ($0 at line $line)");
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
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
257 test_err("# Couldn't open file");
261 test_diag("Couldn't open file");
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
266 Test::Builder->new->diag("foo\n","bar\n");
270 test_diag("foo","bar")
272 without the newlines.
278 # do we need to do any setup?
279 _start_testing() unless $testing;
281 # expect the same thing, but prepended with "# "
283 $err->expect(map {"# $_"} @_)
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>.
292 This takes name/value pairs that effect how the test is run.
296 =item title (synonym 'name', 'label')
298 The name of the test that will be displayed after the C<ok> or C<not
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>.
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>.
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.)
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>.
327 # decode the arguements as described in the pod
335 $mess = $args{name} if exists($args{name});
336 $mess = $args{title} if exists($args{title});
337 $mess = $args{label} if exists($args{label});
340 # er, are we testing?
341 croak "Not testing. You must declare output with a test function first."
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);
349 # restore the test no, etc, back to the original point
350 $t->current_test($testing_num);
353 # re-enable the original setting of the harness
354 $ENV{HARNESS_ACTIVE} = $original_harness_env;
356 # check the output we've stashed
357 unless ($t->ok( ($args{skip_out} || $out->check)
358 && ($args{skip_err} || $err->check),
361 # print out the diagnostic information about why this
366 $t->diag(map {"$_\n"} $out->complaint)
367 unless $args{skip_out} || $out->check;
369 $t->diag(map {"$_\n"} $err->complaint)
370 unless $args{skip_err} || $err->check;
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 methods that contain line numbers.
381 Essentially this is the same as the C<__LINE__> macro, but the
382 C<line_num(+3)> idiom is arguably nicer.
388 my ($package, $filename, $line) = caller;
389 return $line + (shift() || 0); # prevent warnings
394 In addition to the six exported functions there there exists one
395 function that can only be accessed with a fully qualified function
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.
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
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
424 To enable colouring from the command line, you can use the
425 B<Text::Builder::Tester::Color> module like so:
427 perl -Mlib=Text::Builder::Tester::Color test.t
429 Or by including the B<Test::Builder::Tester::Color> module directly in
437 $color = shift if @_;
445 Calls B<Test::Builder>'s C<no_ending> method turning off the ending
446 tests. This is needed as otherwise it will trip out because we've run
447 more tests than we strictly should have and it'll register any
448 failures we had that we were testing for as real failures.
450 The color function doesn't work unless B<Term::ANSIColor> is installed
451 and is compatible with your terminal.
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>
459 Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
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
466 This program is free software; you can redistribute it
467 and/or modify it under the same terms as Perl itself.
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.
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.
479 L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>.
485 ####################################################################
486 # Helper class that is used to remember expected and received data
488 package Test::Tester::Tie;
491 # add line(s) to be expected
498 foreach my $check (@checks) {
499 $check = $self->_translate_Failed_check($check);
500 push @{$self->[2]}, ref $check ? $check : "$check\n";
505 sub _translate_Failed_check
507 my($self, $check) = @_;
509 if( $check =~ /\A(.*)# (Failed .*test) \((.*?) at line (\d+)\)\z/ ) {
510 $check = qr/\Q$1\E#\s+\Q$2\E.*?\n?.*?\Q$3\E at line \Q$4\E.*\n?/;
518 # return true iff the expected data matches the got data
524 # turn off warnings as these might be undef
527 my @checks = @{$self->[2]};
528 my $got = $self->[1];
529 foreach my $check (@checks) {
530 $check = qr/^\Q$check\E/ unless ref $check;
531 return 0 unless $got =~ s/^$check//;
534 return length $got == 0;
538 # a complaint message about the inputs not matching (to be
539 # used for debugging messages)
544 my $type = $self->type;
545 my $got = $self->got;
546 my $wanted = join "\n", @{$self->wanted};
548 # are we running in colour mode?
549 if (Test::Builder::Tester::color)
552 eval "require Term::ANSIColor";
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");
563 # work out where the two strings start to differ
565 $char++ while substr($got, $char, 1) eq substr($wanted, $char, 1);
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;
572 # make the start turn green on and off
573 $start =~ s/\n/$reset\n$green/g;
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;
579 # rebuild the strings
580 $got = $start . $gotend;
581 $wanted = $start . $wantedend;
585 return "$type is:\n" .
586 "$got\nnot:\n$wanted\nas expected"
590 # forget all expected and got data
595 @$self = ($self->[0], '', []);
623 $self->[1] .= join '', @_;
627 my($class, $type) = @_;
629 my $self = bless [$type], $class;