1 package Test::Builder::Tester;
4 our $VERSION = '1.301001_064';
5 $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
7 use Test::Builder 1.301001;
9 use Test::Stream::Carp qw/croak/;
13 Test::Builder::Tester - *DEPRECATED* test testsuites that have been built with
18 B<This module is deprecated.> Please see L<Test::Stream::Tester> for a
19 better alternative that does not involve dealing with TAP/string output.
23 use Test::Builder::Tester tests => 1;
26 test_out("not ok 1 - foo");
29 test_test("fail works");
33 A module that helps you test testing modules that are built with
36 The testing system is designed to be used by performing a three step
37 process for each test you wish to test. This process starts with using
38 C<test_out> and C<test_err> in advance to declare what the testsuite you
39 are testing will output with L<Test::Builder> to stdout and stderr.
41 You then can run the test(s) from your test suite that call
42 L<Test::Builder>. At this point the output of L<Test::Builder> is
43 safely captured by L<Test::Builder::Tester> rather than being
44 interpreted as real test output.
46 The final stage is to call C<test_test> that will simply compare what you
47 predeclared to what L<Test::Builder> actually outputted, and report the
48 results back with a "ok" or "not ok" (with debugging) to the normal
57 #my $t = Test::Builder->new;
63 use Test::Stream::Toolset;
64 use Test::Stream::Exporter;
65 default_exports qw/test_out test_err test_fail test_diag test_test line_num/;
66 Test::Stream::Exporter->cleanup;
70 my ($importer, $list) = @_;
72 my $meta = init_tester($importer);
73 my $context = context(1);
77 while ($idx <= $#{$list}) {
78 my $item = $list->[$idx++];
81 if (defined $item and $item eq 'no_diag') {
82 Test::Stream->shared->set_no_diag(1);
84 elsif ($item eq 'tests') {
85 $context->plan($list->[$idx++]);
87 elsif ($item eq 'skip_all') {
88 $context->plan(0, 'SKIP', $list->[$idx++]);
90 elsif ($item eq 'no_plan') {
91 $context->plan(0, 'NO PLAN');
93 elsif ($item eq 'import') {
94 push @$other => @{$list->[$idx++]};
104 sub builder { Test::Builder->new }
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::Builder::Tester::Tie", "STDOUT";
116 my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR";
122 # for remembering that we're testing and where we're testing at
125 my $original_is_passing;
130 # remembering where the file handles were originally connected
131 my $original_output_handle;
132 my $original_failure_handle;
133 my $original_todo_handle;
135 my $original_harness_env;
137 # 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 $original_stream = builder->{stream} || Test::Stream->shared;
145 $original_state = [@{$original_stream->state->[-1]}];
147 # remember what the handles were set to
148 $original_output_handle = builder()->output();
149 $original_failure_handle = builder()->failure_output();
150 $original_todo_handle = builder()->todo_output();
152 # switch out to our own handles
153 builder()->output($output_handle);
154 builder()->failure_output($error_handle);
155 builder()->todo_output($output_handle);
157 # clear the expected list
161 # remember that we're testing
163 $testing_num = builder()->current_test;
164 builder()->current_test(0);
165 $original_is_passing = builder()->is_passing;
166 builder()->is_passing(1);
168 # look, we shouldn't do the ending stuff
169 builder()->no_ending(1);
174 These are the six methods that are exported as default.
182 Procedures for predeclaring the output that your test suite is
183 expected to produce until C<test_test> is called. These procedures
184 automatically assume that each line terminates with "\n". So
186 test_out("ok 1","ok 2");
190 test_out("ok 1\nok 2");
192 which is even the same as
197 Once C<test_out> or C<test_err> (or C<test_fail> or C<test_diag>) have
198 been called, all further output from L<Test::Builder> will be
199 captured by L<Test::Builder::Tester>. This means that you will not
200 be able perform further tests to the normal output in the normal way
201 until you call C<test_test> (well, unless you manually meddle with the
208 # do we need to do any setup?
209 _start_testing() unless $testing;
216 # do we need to do any setup?
217 _start_testing() unless $testing;
224 Because the standard failure message that L<Test::Builder> produces
225 whenever a test fails will be a common occurrence in your test error
226 output, and because it has changed between Test::Builder versions, rather
227 than forcing you to call C<test_err> with the string all the time like
230 test_err("# Failed test ($0 at line ".line_num(+1).")");
232 C<test_fail> exists as a convenience function that can be called
233 instead. It takes one argument, the offset from the current line that
234 the line that causes the fail is on.
238 This means that the example in the synopsis could be rewritten
241 test_out("not ok 1 - foo");
244 test_test("fail works");
250 # do we need to do any setup?
251 _start_testing() unless $testing;
253 # work out what line we should be on
254 my( $package, $filename, $line ) = caller;
255 $line = $line + ( shift() || 0 ); # prevent warnings
257 # expect that on stderr
258 $err->expect("# Failed test ($filename at line $line)");
263 As most of the remaining expected output to the error stream will be
264 created by L<Test::Builder>'s C<diag> function, L<Test::Builder::Tester>
265 provides a convenience function C<test_diag> that you can use instead of
268 The C<test_diag> function prepends comment hashes and spacing to the
269 start and newlines to the end of the expected output passed to it and
270 adds it to the list of expected error output. So, instead of writing
272 test_err("# Couldn't open file");
276 test_diag("Couldn't open file");
278 Remember that L<Test::Builder>'s diag function will not add newlines to
279 the end of output and test_diag will. So to check
281 Test::Builder->new->diag("foo\n","bar\n");
285 test_diag("foo","bar")
287 without the newlines.
293 # do we need to do any setup?
294 _start_testing() unless $testing;
296 # expect the same thing, but prepended with "# "
298 $err->expect( map { m/\S/ ? "# $_" : "" } @_ );
303 Actually performs the output check testing the tests, comparing the
304 data (with C<eq>) that we have captured from L<Test::Builder> against
305 what was declared with C<test_out> and C<test_err>.
307 This takes name/value pairs that effect how the test is run.
311 =item title (synonym 'name', 'label')
313 The name of the test that will be displayed after the C<ok> or C<not
318 Setting this to a true value will cause the test to ignore if the
319 output sent by the test to the output stream does not match that
320 declared with C<test_out>.
324 Setting this to a true value will cause the test to ignore if the
325 output sent by the test to the error stream does not match that
326 declared with C<test_err>.
330 As a convenience, if only one argument is passed then this argument
331 is assumed to be the name of the test (as in the above examples.)
333 Once C<test_test> has been run test output will be redirected back to
334 the original filehandles that L<Test::Builder> was connected to
335 (probably STDOUT and STDERR,) meaning any further tests you run
336 will function normally and cause success/errors for L<Test::Harness>.
342 # decode the arguments as described in the pod
350 $mess = $args{name} if exists( $args{name} );
351 $mess = $args{title} if exists( $args{title} );
352 $mess = $args{label} if exists( $args{label} );
355 # er, are we testing?
356 croak "Not testing. You must declare output with a test function first."
359 # okay, reconnect the test suite back to the saved handles
360 builder()->output($original_output_handle);
361 builder()->failure_output($original_failure_handle);
362 builder()->todo_output($original_todo_handle);
364 # restore the test no, etc, back to the original point
365 builder()->current_test($testing_num);
367 builder()->is_passing($original_is_passing);
369 # re-enable the original setting of the harness
370 $ENV{HARNESS_ACTIVE} = $original_harness_env;
372 $original_stream->state->[-1] = $original_state;
374 # check the output we've stashed
375 unless( builder()->ok( ( $args{skip_out} || $out->check ) &&
376 ( $args{skip_err} || $err->check ), $mess )
379 # print out the diagnostic information about why this
384 builder()->diag( map { "$_\n" } $out->complaint )
385 unless $args{skip_out} || $out->check;
387 builder()->diag( map { "$_\n" } $err->complaint )
388 unless $args{skip_err} || $err->check;
394 A utility function that returns the line number that the function was
395 called on. You can pass it an offset which will be added to the
396 result. This is very useful for working out the correct text of
397 diagnostic functions that contain line numbers.
399 Essentially this is the same as the C<__LINE__> macro, but the
400 C<line_num(+3)> idiom is arguably nicer.
405 my( $package, $filename, $line ) = caller;
406 return $line + ( shift() || 0 ); # prevent warnings
411 In addition to the six exported functions there exists one
412 function that can only be accessed with a fully qualified function
419 When C<test_test> is called and the output that your tests generate
420 does not match that which you declared, C<test_test> will print out
421 debug information showing the two conflicting versions. As this
422 output itself is debug information it can be confusing which part of
423 the output is from C<test_test> and which was the original output from
424 your original tests. Also, it may be hard to spot things like
425 extraneous whitespace at the end of lines that may cause your test to
426 fail even though the output looks similar.
428 To assist you C<test_test> can colour the background of the debug
429 information to disambiguate the different types of output. The debug
430 output will have its background coloured green and red. The green
431 part represents the text which is the same between the executed and
432 actual output, the red shows which part differs.
434 The C<color> function determines if colouring should occur or not.
435 Passing it a true or false value will enable or disable colouring
436 respectively, and the function called with no argument will return the
439 To enable colouring from the command line, you can use the
440 L<Text::Builder::Tester::Color> module like so:
442 perl -Mlib=Text::Builder::Tester::Color test.t
444 Or by including the L<Test::Builder::Tester::Color> module directly in
452 $color = shift if @_;
460 Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting
461 me use his testing system to try this module out on.
465 L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>.
471 The source code repository for Test::More can be found at
472 F<http://github.com/Test-More/test-more/>.
478 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
484 The following people have all contributed to the Test-More dist (sorted using
485 VIM's sort function).
489 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
491 =item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
493 =item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
495 =item Michael G Schwern E<lt>schwern@pobox.comE<gt>
503 There has been a lot of code migration between modules,
504 here are all the original copyrights together:
510 =item Test::Stream::Tester
512 Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
514 This program is free software; you can redistribute it and/or
515 modify it under the same terms as Perl itself.
517 See F<http://www.perl.com/perl/misc/Artistic.html>
525 Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
526 inspiration from Joshua Pritikin's Test module and lots of help from Barrie
527 Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
530 Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
531 E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
533 Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
535 This program is free software; you can redistribute it and/or
536 modify it under the same terms as Perl itself.
538 See F<http://www.perl.com/perl/misc/Artistic.html>
542 To the extent possible under law, 唐鳳 has waived all copyright and related
543 or neighboring rights to L<Test-use-ok>.
545 This work is published from Taiwan.
547 L<http://creativecommons.org/publicdomain/zero/1.0>
551 This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
552 are based on other people's work.
554 Under the same license as Perl itself
556 See http://www.perl.com/perl/misc/Artistic.html
558 =item Test::Builder::Tester
560 Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
562 This program is free software; you can redistribute it
563 and/or modify it under the same terms as Perl itself.
571 ####################################################################
572 # Helper class that is used to remember expected and received data
574 package Test::Builder::Tester::Tie;
577 # add line(s) to be expected
583 foreach my $check (@checks) {
584 $check = $self->_account_for_subtest($check);
585 $check = $self->_translate_Failed_check($check);
586 push @{ $self->{wanted} }, ref $check ? $check : "$check\n";
590 sub _account_for_subtest {
591 my( $self, $check ) = @_;
593 my $ctx = Test::Stream::Context::context();
594 my $depth = @{$ctx->stream->subtests};
595 # Since we ship with Test::Builder, calling a private method is safe...ish.
596 return ref($check) ? $check : ($depth ? ' ' x $depth : '') . $check;
599 sub _translate_Failed_check {
600 my( $self, $check ) = @_;
602 if( $check =~ /\A(.*)# (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) {
603 $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/";
610 # return true iff the expected data matches the got data
615 # turn off warnings as these might be undef
618 my @checks = @{ $self->{wanted} };
619 my $got = $self->{got};
620 foreach my $check (@checks) {
621 $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check );
622 return 0 unless $got =~ s/^$check//;
625 return length $got == 0;
629 # a complaint message about the inputs not matching (to be
630 # used for debugging messages)
634 my $type = $self->type;
635 my $got = $self->got;
636 my $wanted = join '', @{ $self->wanted };
638 # are we running in colour mode?
639 if(Test::Builder::Tester::color) {
641 eval { require Term::ANSIColor };
645 my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green");
646 my $red = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_red");
647 my $reset = Term::ANSIColor::color("reset");
649 # work out where the two strings start to differ
651 $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 );
653 # get the start string and the two end strings
654 my $start = $green . substr( $wanted, 0, $char );
655 my $gotend = $red . substr( $got, $char ) . $reset;
656 my $wantedend = $red . substr( $wanted, $char ) . $reset;
658 # make the start turn green on and off
659 $start =~ s/\n/$reset\n$green/g;
661 # make the ends turn red on and off
662 $gotend =~ s/\n/$reset\n$red/g;
663 $wantedend =~ s/\n/$reset\n$red/g;
665 # rebuild the strings
666 $got = $start . $gotend;
667 $wanted = $start . $wantedend;
671 return "$type is:\n" . "$got\nnot:\n$wanted\nas expected";
675 # forget all expected and got data
680 type => $self->{type},
693 return $self->{wanted};
698 return $self->{type};
707 $self->{got} .= join '', @_;
711 my( $class, $type ) = @_;
713 my $self = bless { type => $type }, $class;