1 package Test::Builder::Tester;
4 our $VERSION = '1.301001_074';
5 $VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
7 use Test::Stream 1.301001 '-internal';
8 use Test::Builder 1.301001;
10 use Test::Stream::Carp qw/croak/;
14 Test::Builder::Tester - *DEPRECATED* test testsuites that have been built with
19 B<This module is deprecated.> Please see L<Test::Stream::Tester> for a
20 better alternative that does not involve dealing with TAP/string output.
24 use Test::Builder::Tester tests => 1;
27 test_out("not ok 1 - foo");
30 test_test("fail works");
34 A module that helps you test testing modules that are built with
37 The testing system is designed to be used by performing a three step
38 process for each test you wish to test. This process starts with using
39 C<test_out> and C<test_err> in advance to declare what the testsuite you
40 are testing will output with L<Test::Builder> to stdout and stderr.
42 You then can run the test(s) from your test suite that call
43 L<Test::Builder>. At this point the output of L<Test::Builder> is
44 safely captured by L<Test::Builder::Tester> rather than being
45 interpreted as real test output.
47 The final stage is to call C<test_test> that will simply compare what you
48 predeclared to what L<Test::Builder> actually outputted, and report the
49 results back with a "ok" or "not ok" (with debugging) to the normal
58 #my $t = Test::Builder->new;
64 use Test::Stream::Toolset;
65 use Test::Stream::Exporter;
66 default_exports qw/test_out test_err test_fail test_diag test_test line_num/;
67 Test::Stream::Exporter->cleanup;
71 my ($importer, $list) = @_;
73 my $meta = init_tester($importer);
74 my $context = context(1);
78 while ($idx <= $#{$list}) {
79 my $item = $list->[$idx++];
82 if (defined $item and $item eq 'no_diag') {
83 Test::Stream->shared->set_no_diag(1);
85 elsif ($item eq 'tests') {
86 $context->plan($list->[$idx++]);
88 elsif ($item eq 'skip_all') {
89 $context->plan(0, 'SKIP', $list->[$idx++]);
91 elsif ($item eq 'no_plan') {
92 $context->plan(0, 'NO PLAN');
94 elsif ($item eq 'import') {
95 push @$other => @{$list->[$idx++]};
105 sub builder { Test::Builder->new }
108 # set up file handles
111 # create some private file handles
112 my $output_handle = gensym;
113 my $error_handle = gensym;
115 # and tie them to this package
116 my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT";
117 my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR";
123 # for remembering that we're testing and where we're testing at
126 my $original_is_passing;
131 # remembering where the file handles were originally connected
132 my $original_output_handle;
133 my $original_failure_handle;
134 my $original_todo_handle;
136 my $original_harness_env;
138 # function that starts testing and redirects the filehandles for now
140 # even if we're running under Test::Harness pretend we're not
141 # for now. This needed so Test::Builder doesn't add extra spaces
142 $original_harness_env = $ENV{HARNESS_ACTIVE} || 0;
143 $ENV{HARNESS_ACTIVE} = 0;
145 $original_stream = builder->{stream} || Test::Stream->shared;
146 $original_state = [@{$original_stream->state->[-1]}];
148 # remember what the handles were set to
149 $original_output_handle = builder()->output();
150 $original_failure_handle = builder()->failure_output();
151 $original_todo_handle = builder()->todo_output();
153 # switch out to our own handles
154 builder()->output($output_handle);
155 builder()->failure_output($error_handle);
156 builder()->todo_output($output_handle);
158 # clear the expected list
162 # remember that we're testing
164 $testing_num = builder()->current_test;
165 builder()->current_test(0);
166 $original_is_passing = builder()->is_passing;
167 builder()->is_passing(1);
169 # look, we shouldn't do the ending stuff
170 builder()->no_ending(1);
175 These are the six methods that are exported as default.
183 Procedures for predeclaring the output that your test suite is
184 expected to produce until C<test_test> is called. These procedures
185 automatically assume that each line terminates with "\n". So
187 test_out("ok 1","ok 2");
191 test_out("ok 1\nok 2");
193 which is even the same as
198 Once C<test_out> or C<test_err> (or C<test_fail> or C<test_diag>) have
199 been called, all further output from L<Test::Builder> will be
200 captured by L<Test::Builder::Tester>. This means that you will not
201 be able perform further tests to the normal output in the normal way
202 until you call C<test_test> (well, unless you manually meddle with the
209 # do we need to do any setup?
210 _start_testing() unless $testing;
217 # do we need to do any setup?
218 _start_testing() unless $testing;
225 Because the standard failure message that L<Test::Builder> produces
226 whenever a test fails will be a common occurrence in your test error
227 output, and because it has changed between Test::Builder versions, rather
228 than forcing you to call C<test_err> with the string all the time like
231 test_err("# Failed test ($0 at line ".line_num(+1).")");
233 C<test_fail> exists as a convenience function that can be called
234 instead. It takes one argument, the offset from the current line that
235 the line that causes the fail is on.
239 This means that the example in the synopsis could be rewritten
242 test_out("not ok 1 - foo");
245 test_test("fail works");
251 # do we need to do any setup?
252 _start_testing() unless $testing;
254 # work out what line we should be on
255 my( $package, $filename, $line ) = caller;
256 $line = $line + ( shift() || 0 ); # prevent warnings
258 # expect that on stderr
259 $err->expect("# Failed test ($filename at line $line)");
264 As most of the remaining expected output to the error stream will be
265 created by L<Test::Builder>'s C<diag> function, L<Test::Builder::Tester>
266 provides a convenience function C<test_diag> that you can use instead of
269 The C<test_diag> function prepends comment hashes and spacing to the
270 start and newlines to the end of the expected output passed to it and
271 adds it to the list of expected error output. So, instead of writing
273 test_err("# Couldn't open file");
277 test_diag("Couldn't open file");
279 Remember that L<Test::Builder>'s diag function will not add newlines to
280 the end of output and test_diag will. So to check
282 Test::Builder->new->diag("foo\n","bar\n");
286 test_diag("foo","bar")
288 without the newlines.
294 # do we need to do any setup?
295 _start_testing() unless $testing;
297 # expect the same thing, but prepended with "# "
299 $err->expect( map { m/\S/ ? "# $_" : "" } @_ );
304 Actually performs the output check testing the tests, comparing the
305 data (with C<eq>) that we have captured from L<Test::Builder> against
306 what was declared with C<test_out> and C<test_err>.
308 This takes name/value pairs that effect how the test is run.
312 =item title (synonym 'name', 'label')
314 The name of the test that will be displayed after the C<ok> or C<not
319 Setting this to a true value will cause the test to ignore if the
320 output sent by the test to the output stream does not match that
321 declared with C<test_out>.
325 Setting this to a true value will cause the test to ignore if the
326 output sent by the test to the error stream does not match that
327 declared with C<test_err>.
331 As a convenience, if only one argument is passed then this argument
332 is assumed to be the name of the test (as in the above examples.)
334 Once C<test_test> has been run test output will be redirected back to
335 the original filehandles that L<Test::Builder> was connected to
336 (probably STDOUT and STDERR,) meaning any further tests you run
337 will function normally and cause success/errors for L<Test::Harness>.
343 # decode the arguments as described in the pod
351 $mess = $args{name} if exists( $args{name} );
352 $mess = $args{title} if exists( $args{title} );
353 $mess = $args{label} if exists( $args{label} );
356 # er, are we testing?
357 croak "Not testing. You must declare output with a test function first."
360 # okay, reconnect the test suite back to the saved handles
361 builder()->output($original_output_handle);
362 builder()->failure_output($original_failure_handle);
363 builder()->todo_output($original_todo_handle);
365 # restore the test no, etc, back to the original point
366 builder()->current_test($testing_num);
368 builder()->is_passing($original_is_passing);
370 # re-enable the original setting of the harness
371 $ENV{HARNESS_ACTIVE} = $original_harness_env;
373 $original_stream->state->[-1] = $original_state;
375 # check the output we've stashed
376 unless( builder()->ok( ( $args{skip_out} || $out->check ) &&
377 ( $args{skip_err} || $err->check ), $mess )
380 # print out the diagnostic information about why this
385 builder()->diag( map { "$_\n" } $out->complaint )
386 unless $args{skip_out} || $out->check;
388 builder()->diag( map { "$_\n" } $err->complaint )
389 unless $args{skip_err} || $err->check;
395 A utility function that returns the line number that the function was
396 called on. You can pass it an offset which will be added to the
397 result. This is very useful for working out the correct text of
398 diagnostic functions that contain line numbers.
400 Essentially this is the same as the C<__LINE__> macro, but the
401 C<line_num(+3)> idiom is arguably nicer.
406 my( $package, $filename, $line ) = caller;
407 return $line + ( shift() || 0 ); # prevent warnings
412 In addition to the six exported functions there exists one
413 function that can only be accessed with a fully qualified function
420 When C<test_test> is called and the output that your tests generate
421 does not match that which you declared, C<test_test> will print out
422 debug information showing the two conflicting versions. As this
423 output itself is debug information it can be confusing which part of
424 the output is from C<test_test> and which was the original output from
425 your original tests. Also, it may be hard to spot things like
426 extraneous whitespace at the end of lines that may cause your test to
427 fail even though the output looks similar.
429 To assist you C<test_test> can colour the background of the debug
430 information to disambiguate the different types of output. The debug
431 output will have its background coloured green and red. The green
432 part represents the text which is the same between the executed and
433 actual output, the red shows which part differs.
435 The C<color> function determines if colouring should occur or not.
436 Passing it a true or false value will enable or disable colouring
437 respectively, and the function called with no argument will return the
440 To enable colouring from the command line, you can use the
441 L<Text::Builder::Tester::Color> module like so:
443 perl -Mlib=Text::Builder::Tester::Color test.t
445 Or by including the L<Test::Builder::Tester::Color> module directly in
453 $color = shift if @_;
461 Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting
462 me use his testing system to try this module out on.
466 L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>.
472 The source code repository for Test::More can be found at
473 F<http://github.com/Test-More/test-more/>.
479 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
485 The following people have all contributed to the Test-More dist (sorted using
486 VIM's sort function).
490 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
492 =item Fergal Daly E<lt>fergal@esatclear.ie>E<gt>
494 =item Mark Fowler E<lt>mark@twoshortplanks.comE<gt>
496 =item Michael G Schwern E<lt>schwern@pobox.comE<gt>
504 There has been a lot of code migration between modules,
505 here are all the original copyrights together:
511 =item Test::Stream::Tester
513 Copyright 2014 Chad Granum E<lt>exodist7@gmail.comE<gt>.
515 This program is free software; you can redistribute it and/or
516 modify it under the same terms as Perl itself.
518 See F<http://www.perl.com/perl/misc/Artistic.html>
526 Originally authored by Michael G Schwern E<lt>schwern@pobox.comE<gt> with much
527 inspiration from Joshua Pritikin's Test module and lots of help from Barrie
528 Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and the perl-qa
531 Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
532 E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
534 Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
536 This program is free software; you can redistribute it and/or
537 modify it under the same terms as Perl itself.
539 See F<http://www.perl.com/perl/misc/Artistic.html>
543 To the extent possible under law, 唐鳳 has waived all copyright and related
544 or neighboring rights to L<Test-use-ok>.
546 This work is published from Taiwan.
548 L<http://creativecommons.org/publicdomain/zero/1.0>
552 This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
553 are based on other people's work.
555 Under the same license as Perl itself
557 See http://www.perl.com/perl/misc/Artistic.html
559 =item Test::Builder::Tester
561 Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
563 This program is free software; you can redistribute it
564 and/or modify it under the same terms as Perl itself.
572 ####################################################################
573 # Helper class that is used to remember expected and received data
575 package Test::Builder::Tester::Tie;
578 # add line(s) to be expected
584 foreach my $check (@checks) {
585 $check = $self->_account_for_subtest($check);
586 $check = $self->_translate_Failed_check($check);
587 push @{ $self->{wanted} }, ref $check ? $check : "$check\n";
591 sub _account_for_subtest {
592 my( $self, $check ) = @_;
594 my $ctx = Test::Stream::Context::context();
595 my $depth = @{$ctx->stream->subtests};
596 # Since we ship with Test::Builder, calling a private method is safe...ish.
597 return ref($check) ? $check : ($depth ? ' ' x $depth : '') . $check;
600 sub _translate_Failed_check {
601 my( $self, $check ) = @_;
603 if( $check =~ /\A(.*)# (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) {
604 $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/";
611 # return true iff the expected data matches the got data
616 # turn off warnings as these might be undef
619 my @checks = @{ $self->{wanted} };
620 my $got = $self->{got};
621 foreach my $check (@checks) {
622 $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check );
623 return 0 unless $got =~ s/^$check//;
626 return length $got == 0;
630 # a complaint message about the inputs not matching (to be
631 # used for debugging messages)
635 my $type = $self->type;
636 my $got = $self->got;
637 my $wanted = join '', @{ $self->wanted };
639 # are we running in colour mode?
640 if(Test::Builder::Tester::color) {
642 eval { require Term::ANSIColor };
646 my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green");
647 my $red = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_red");
648 my $reset = Term::ANSIColor::color("reset");
650 # work out where the two strings start to differ
652 $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 );
654 # get the start string and the two end strings
655 my $start = $green . substr( $wanted, 0, $char );
656 my $gotend = $red . substr( $got, $char ) . $reset;
657 my $wantedend = $red . substr( $wanted, $char ) . $reset;
659 # make the start turn green on and off
660 $start =~ s/\n/$reset\n$green/g;
662 # make the ends turn red on and off
663 $gotend =~ s/\n/$reset\n$red/g;
664 $wantedend =~ s/\n/$reset\n$red/g;
666 # rebuild the strings
667 $got = $start . $gotend;
668 $wanted = $start . $wantedend;
672 return "$type is:\n" . "$got\nnot:\n$wanted\nas expected";
676 # forget all expected and got data
681 type => $self->{type},
694 return $self->{wanted};
699 return $self->{type};
708 $self->{got} .= join '', @_;
712 my( $class, $type ) = @_;
714 my $self = bless { type => $type }, $class;