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;
23 test_test("fail works");
27 test_test("pass works");
29 test_fail(+3, "is foo bar?");
30 test_err("# got: 'foo'",
32 is("foo", "bar", "is foo bar?");
33 test_test("diagnostic checking works");
38 A module that helps you test testing modules that are built with
41 The testing system is designed to be used by performing a three step
42 process for each test you wish to test. This process starts with using
43 Test::Builder::Tester functions to declare what the testsuite you
44 are testing will output with B<Test::Builder>.
46 You then can run the test(s) from your test suite that call
47 B<Test::Builder>. At this point the output of B<Test::Builder> is
48 safely captured by B<Test::Builder::Tester> rather than being
49 interpreted as real test output.
51 The final stage is to call C<test_test> that will simply compare what you
52 predeclared to what B<Test::Builder> actually outputted, and report the
53 results back with a "ok" or "not ok" (with debugging) to the normal
62 my $t = Test::Builder->new;
71 @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num test_pass);
73 # _export_to_level and import stolen directly from Test::More. I am
74 # the king of cargo cult programming ;-)
76 # 5.004's Exporter doesn't have export_to_level.
81 (undef) = shift; # XXX redundant arg
82 my $callpkg = caller($level);
83 $pkg->export($callpkg, @_);
92 $t->exported_to($caller);
96 foreach my $idx (0..$#plan) {
97 if( $plan[$idx] eq 'import' ) {
98 @imports = @{$plan[$idx+1]};
103 __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
107 # set up file handles
110 # create some private file handles
111 my $output_handle = gensym;
112 my $error_handle = gensym;
114 # and tie them to this package
115 my $out = tie *$output_handle, "Test::Tester::Tie", "STDOUT";
116 my $err = tie *$error_handle, "Test::Tester::Tie", "STDERR";
122 # for remembering that we're testing and where we're testing at
126 # remembering where the file handles were originally connected
127 my $original_output_handle;
128 my $original_failure_handle;
129 my $original_todo_handle;
131 my $original_test_number;
132 my $original_harness_state;
134 my $original_harness_env;
136 # function that starts testing and redirects the filehandles for now
139 # even if we're running under Test::Harness pretend we're not
140 # for now. This needed so Test::Builder doesn't add extra spaces
141 $original_harness_env = $ENV{HARNESS_ACTIVE} || 0;
142 $ENV{HARNESS_ACTIVE} = 0;
144 # remember what the handles were set to
145 $original_output_handle = $t->output();
146 $original_failure_handle = $t->failure_output();
147 $original_todo_handle = $t->todo_output();
149 # switch out to our own handles
150 $t->output($output_handle);
151 $t->failure_output($error_handle);
152 $t->todo_output($error_handle);
154 # clear the expected list
158 # remeber that we're testing
160 $testing_num = $t->current_test;
163 # look, we shouldn't do the ending stuff
169 These are the functions exported by default.
176 test_pass($description);
178 Because the standard success message that B<Test::Builder> produces
179 whenever a test passes will be common in your test error
180 output, rather than forcing you to call C<test_out> with the string
183 test_out("ok 1 - some test name here");
185 C<test_pass> exists as a convenience function that you can call instead. It
186 takes one optional argument, the test description from the test you expect to
187 pass. The following is equivalent to the above C<test_out> call.
189 test_pass("some test name here");
195 _start_testing() unless $testing++;
196 my $mess = "ok $testing";
197 $mess .= ' - ' . shift if @_;
198 $out->expect( $mess, @_ );
204 test_fail($line_num_offset);
205 test_fail($line_num_offset, $description);
207 Because the standard failure message that B<Test::Builder> produces
208 whenever a test fails will be a common occurrence in your test error
209 output, and because has changed between Test::Builder versions, rather
210 than forcing you to call C<test_err> with the string all the time like
213 test_err("# Failed test ($0 at line ".line_num(+1).")");
215 C<test_fail> exists as a convenience function that can be called
216 instead. It takes one argument, the offset from the current line that
217 the line that causes the fail is on.
222 It optionally takes the $description of the test.
224 test_fail(+1, "kaboom");
231 # do we need to do any setup?
232 _start_testing() unless $testing++;
234 # work out what line we should be on
235 my ($package, $filename, $line) = caller;
236 $line = $line + (shift() || 0); # prevent warnings
238 my $mess = "not ok $testing";
239 $mess .= ' - ' . shift if @_;
240 $out->expect( $mess );
242 # expect that on stderr
243 $err->expect("# Failed test ($0 at line $line)");
253 test_err(@diagnostic_output);
255 Procedures for predeclaring the output that your test suite is
256 expected to produce until C<test_test> is called. These procedures
257 automatically assume that each line terminates with "\n". So
259 test_out("foo","bar");
263 test_out("foo\nbar");
265 which is even the same as
270 Once C<test_out> or C<test_err> (or C<test_fail>, C<test_pass>, or
271 C<test_diag>) have been called once all further output from B<Test::Builder>
272 will be captured by B<Test::Builder::Tester>. This means that your will not be
273 able perform further tests to the normal output in the normal way until you
280 # do we need to do any setup?
281 _start_testing() unless $testing;
288 # do we need to do any setup?
289 _start_testing() unless $testing;
297 As most of the remaining expected output to the error stream will be
298 created by Test::Builder's C<diag> function, B<Test::Builder::Tester>
299 provides a convience function C<test_diag> that you can use instead of
302 The C<test_diag> function prepends comment hashes and spacing to the
303 start and newlines to the end of the expected output passed to it and
304 adds it to the list of expected error output. So, instead of writing
306 test_err("# Couldn't open file");
310 test_diag("Couldn't open file");
312 Remember that B<Test::Builder>'s diag function will not add newlines to
313 the end of output and test_diag will. So to check
315 Test::Builder->new->diag("foo\n","bar\n");
319 test_diag("foo","bar")
321 without the newlines.
327 # do we need to do any setup?
328 _start_testing() unless $testing;
330 # expect the same thing, but prepended with "# "
332 $err->expect(map {"# $_"} @_)
337 Actually performs the output check testing the tests, comparing the
338 data (with C<eq>) that we have captured from B<Test::Builder> against
339 that that was declared with C<test_out> and C<test_err>.
341 This takes name/value pairs that effect how the test is run.
345 =item title (synonym 'name', 'label')
347 The name of the test that will be displayed after the C<ok> or C<not
352 Setting this to a true value will cause the test to ignore if the
353 output sent by the test to the output stream does not match that
354 declared with C<test_out>.
358 Setting this to a true value will cause the test to ignore if the
359 output sent by the test to the error stream does not match that
360 declared with C<test_err>.
364 As a convience, if only one argument is passed then this argument
365 is assumed to be the name of the test (as in the above examples.)
367 Once C<test_test> has been run test output will be redirected back to
368 the original filehandles that B<Test::Builder> was connected to
369 (probably STDOUT and STDERR,) meaning any further tests you run
370 will function normally and cause success/errors for B<Test::Harness>.
376 # decode the arguements as described in the pod
384 $mess = $args{name} if exists($args{name});
385 $mess = $args{title} if exists($args{title});
386 $mess = $args{label} if exists($args{label});
389 # er, are we testing?
390 croak "Not testing. You must declare output with a test function first."
393 # okay, reconnect the test suite back to the saved handles
394 $t->output($original_output_handle);
395 $t->failure_output($original_failure_handle);
396 $t->todo_output($original_todo_handle);
398 # restore the test no, etc, back to the original point
399 $t->current_test($testing_num);
402 # re-enable the original setting of the harness
403 $ENV{HARNESS_ACTIVE} = $original_harness_env;
405 # check the output we've stashed
406 unless ($t->ok( ($args{skip_out} || $out->check)
407 && ($args{skip_err} || $err->check),
414 $t->diag(map {"$_\n"} $out->complaint)
415 unless $args{skip_out} || $out->check;
417 $t->diag(map {"$_\n"} $err->complaint)
418 unless $args{skip_err} || $err->check;
424 A utility function that returns the line number that the function was
425 called on. You can pass it an offset which will be added to the
426 result. This is very useful for working out the correct text of
427 diagnostic functions that contain line numbers.
429 Essentially this is the same as the C<__LINE__> macro, but the
430 C<line_num(+3)> idiom is arguably nicer.
436 my ($package, $filename, $line) = caller;
437 return $line + (shift() || 0); # prevent warnings
442 In addition to the six exported functions there there exists one
443 function that can only be accessed with a fully qualified function
450 When C<test_test> is called and the output that your tests generate
451 does not match that which you declared, C<test_test> will print out
452 debug information showing the two conflicting versions. As this
453 output itself is debug information it can be confusing which part of
454 the output is from C<test_test> and which was the original output from
455 your original tests. Also, it may be hard to spot things like
456 extraneous whitespace at the end of lines that may cause your test to
457 fail even though the output looks similar.
459 To assist you, if you have the B<Term::ANSIColor> module installed
460 (which you should do by default from perl 5.005 onwards), C<test_test>
461 can colour the background of the debug information to disambiguate the
462 different types of output. The debug output will have it's background
463 coloured green and red. The green part represents the text which is
464 the same between the executed and actual output, the red shows which
467 The C<color> function determines if colouring should occur or not.
468 Passing it a true or false value will enable or disable colouring
469 respectively, and the function called with no argument will return the
472 To enable colouring from the command line, you can use the
473 B<Text::Builder::Tester::Color> module like so:
475 perl -Mlib=Text::Builder::Tester::Color test.t
477 Or by including the B<Test::Builder::Tester::Color> module directly in
485 $color = shift if @_;
493 Calls C<<Test::Builder->no_ending>> turning off the ending tests.
494 This is needed as otherwise it will trip out because we've run more
495 tests than we strictly should have and it'll register any failures we
496 had that we were testing for as real failures.
498 The color function doesn't work unless B<Term::ANSIColor> is installed
499 and is compatible with your terminal.
501 Bugs (and requests for new features) can be reported to the author
502 though the CPAN RT system:
503 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Builder-Tester>
507 Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
509 Some code taken from B<Test::More> and B<Test::Catch>, written by by
510 Michael G Schwern E<lt>schwern@pobox.comE<gt>. Hence, those parts
511 Copyright Micheal G Schwern 2001. Used and distributed with
514 This program is free software; you can redistribute it
515 and/or modify it under the same terms as Perl itself.
519 This code has been tested explicitly on the following versions
520 of perl: 5.7.3, 5.6.1, 5.6.0, 5.005_03, 5.004_05 and 5.004.
522 Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting
523 me use his testing system to try this module out on.
527 L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>.
533 ####################################################################
534 # Helper class that is used to remember expected and received data
536 package Test::Tester::Tie;
539 # add line(s) to be expected
546 foreach my $check (@checks) {
547 $check = $self->_translate_Failed_check($check);
548 push @{$self->[2]}, ref $check ? $check : "$check\n";
553 sub _translate_Failed_check
555 my($self, $check) = @_;
557 if( $check =~ /\A(.*)# (Failed .*test) \((.*?) at line (\d+)\)\z/ ) {
558 $check = qr/\Q$1\E#\s+\Q$2\E.*?\n?.*?\Q$3\E at line \Q$4\E.*\n?/;
566 # return true iff the expected data matches the got data
572 # turn off warnings as these might be undef
575 my @checks = @{$self->[2]};
576 my $got = $self->[1];
577 foreach my $check (@checks) {
578 $check = qr/^\Q$check\E/ unless ref $check;
579 return 0 unless $got =~ s/^$check//;
582 return length $got == 0;
586 # a complaint message about the inputs not matching (to be
587 # used for debugging messages)
592 my $type = $self->type;
593 my $got = $self->got;
594 my $wanted = join '', @{$self->wanted};
596 # are we running in colour mode?
597 if (Test::Builder::Tester::color)
600 eval "require Term::ANSIColor";
605 my $green = Term::ANSIColor::color("black").
606 Term::ANSIColor::color("on_green");
607 my $red = Term::ANSIColor::color("black").
608 Term::ANSIColor::color("on_red");
609 my $reset = Term::ANSIColor::color("reset");
611 # work out where the two strings start to differ
613 $char++ while substr($got, $char, 1) eq substr($wanted, $char, 1);
615 # get the start string and the two end strings
616 my $start = $green . substr($wanted, 0, $char);
617 my $gotend = $red . substr($got , $char) . $reset;
618 my $wantedend = $red . substr($wanted, $char) . $reset;
620 # make the start turn green on and off
621 $start =~ s/\n/$reset\n$green/g;
623 # make the ends turn red on and off
624 $gotend =~ s/\n/$reset\n$red/g;
625 $wantedend =~ s/\n/$reset\n$red/g;
627 # rebuild the strings
628 $got = $start . $gotend;
629 $wanted = $start . $wantedend;
633 return "$type is:\n" .
634 "$got\nnot:\n$wanted\nas expected"
638 # forget all expected and got data
643 @$self = ($self->[0], '', []);
671 $self->[1] .= join '', @_;
675 my($class, $type) = @_;
677 my $self = bless [$type], $class;