[p5sagit/p5-mst-13.2.git] / lib / Test / Builder / Tester.pm

package Test::Builder::Tester;

use strict;
use vars qw(@EXPORT $VERSION @ISA);
$VERSION = "1.03";

use Test::Builder;
use Symbol;
use Carp;

=head1 NAME

Test::Builder::Tester - test testsuites that have been built with
Test::Builder

=head1 SYNOPSIS

    use Test::Builder::Tester tests => 1;
    use Test::More;

    test_fail(+1, "foo");
    fail("foo");
    test_test("fail works");

    test_pass("baz");
    ok(1, "baz");
    test_test("pass works");

    test_fail(+3, "is foo bar?");
    test_err("#          got: 'foo'",
             "#     expected: 'bar'");
    is("foo", "bar", "is foo bar?");
    test_test("diagnostic checking works");


=head1 DESCRIPTION

A module that helps you test testing modules that are built with
B<Test::Builder>.

The testing system is designed to be used by performing a three step
process for each test you wish to test.  This process starts with using
Test::Builder::Tester functions to declare what the testsuite you
are testing will output with B<Test::Builder>.

You then can run the test(s) from your test suite that call
B<Test::Builder>.  At this point the output of B<Test::Builder> is
safely captured by B<Test::Builder::Tester> rather than being
interpreted as real test output.

The final stage is to call C<test_test> that will simply compare what you
predeclared to what B<Test::Builder> actually outputted, and report the
results back with a "ok" or "not ok" (with debugging) to the normal
output.

=cut

####
# set up testing
####

my $t = Test::Builder->new;

###
# make us an exporter
###

use Exporter;
@ISA = qw(Exporter);

@EXPORT = qw(test_out test_err test_fail test_diag test_test line_num test_pass);

# _export_to_level and import stolen directly from Test::More.  I am
# the king of cargo cult programming ;-)

# 5.004's Exporter doesn't have export_to_level.
sub _export_to_level
{
      my $pkg = shift;
      my $level = shift;
      (undef) = shift;                  # XXX redundant arg
      my $callpkg = caller($level);
      $pkg->export($callpkg, @_);
}

sub import {
    my $class = shift;
    my(@plan) = @_;

    my $caller = caller;

    $t->exported_to($caller);
    $t->plan(@plan);

    my @imports = ();
    foreach my $idx (0..$#plan) {
        if( $plan[$idx] eq 'import' ) {
            @imports = @{$plan[$idx+1]};
            last;
        }
    }

    __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
}

###
# set up file handles
###

# create some private file handles
my $output_handle = gensym;
my $error_handle  = gensym;

# and tie them to this package
my $out = tie *$output_handle, "Test::Tester::Tie", "STDOUT";
my $err = tie *$error_handle,  "Test::Tester::Tie", "STDERR";

####
# exported functions
####

# for remembering that we're testing and where we're testing at
my $testing = 0;
my $testing_num;

# remembering where the file handles were originally connected
my $original_output_handle;
my $original_failure_handle;
my $original_todo_handle;

my $original_test_number;
my $original_harness_state;

my $original_harness_env;

# function that starts testing and redirects the filehandles for now
sub _start_testing
{
    # even if we're running under Test::Harness pretend we're not
    # for now.  This needed so Test::Builder doesn't add extra spaces
    $original_harness_env = $ENV{HARNESS_ACTIVE} || 0;
    $ENV{HARNESS_ACTIVE} = 0;

    # remember what the handles were set to
    $original_output_handle  = $t->output();
    $original_failure_handle = $t->failure_output();
    $original_todo_handle    = $t->todo_output();

    # switch out to our own handles
    $t->output($output_handle);
    $t->failure_output($error_handle);
    $t->todo_output($error_handle);

    # clear the expected list
    $out->reset();
    $err->reset();

    # remeber that we're testing
    $testing = 1;
    $testing_num = $t->current_test;
    $t->current_test(0);

    # look, we shouldn't do the ending stuff
    $t->no_ending(1);
}

=head2 Functions

These are the functions exported by default.

=over 4

=item test_pass

    test_pass();
    test_pass($description);

Because the standard success message that B<Test::Builder> produces
whenever a test passes will be common in your test error
output, rather than forcing you to call C<test_out> with the string
all the time like so

    test_out("ok 1 - some test name here");

C<test_pass> exists as a convenience function that you can call instead.  It
takes one optional argument, the test description from the test you expect to
pass.  The following is equivalent to the above C<test_out> call.

    test_pass("some test name here");

=cut

sub test_pass(;$)
{
    _start_testing() unless $testing++;
    my $mess = "ok $testing";
    $mess .= ' - ' . shift if @_;
    $out->expect( $mess, @_ );
}


=item test_fail

    test_fail($line_num_offset);
    test_fail($line_num_offset, $description);

Because the standard failure message that B<Test::Builder> produces
whenever a test fails will be a common occurrence in your test error
output, and because has changed between Test::Builder versions, rather
than forcing you to call C<test_err> with the string all the time like
so

    test_err("# Failed test ($0 at line ".line_num(+1).")");

C<test_fail> exists as a convenience function that can be called
instead.  It takes one argument, the offset from the current line that
the line that causes the fail is on.

    test_fail(+1);
    ok(0);

It optionally takes the $description of the test.

    test_fail(+1, "kaboom");
    fail("kaboom");

=cut

sub test_fail
{
    # do we need to do any setup?
    _start_testing() unless $testing++;

    # work out what line we should be on
    my ($package, $filename, $line) = caller;
    $line = $line + (shift() || 0); # prevent warnings

    my $mess = "not ok $testing";
    $mess .= ' - ' . shift if @_;
    $out->expect( $mess );

    # expect that on stderr
    $err->expect("#     Failed test ($0 at line $line)");
}


=item test_out

    test_out(@output);

=item test_err

    test_err(@diagnostic_output);

Procedures for predeclaring the output that your test suite is
expected to produce until C<test_test> is called.  These procedures
automatically assume that each line terminates with "\n".  So

   test_out("foo","bar");

is the same as

   test_out("foo\nbar");

which is even the same as

   test_out("foo");
   test_out("bar");

Once C<test_out> or C<test_err> (or C<test_fail>, C<test_pass>, or
C<test_diag>) have been called once all further output from B<Test::Builder>
will be captured by B<Test::Builder::Tester>.  This means that your will not be
able perform further tests to the normal output in the normal way until you
call C<test_test>.

=cut

sub test_out(@)
{
    # do we need to do any setup?
    _start_testing() unless $testing;

    $out->expect(@_)
}

sub test_err(@)
{
    # do we need to do any setup?
    _start_testing() unless $testing;

    $err->expect(@_)
}


=item test_diag

As most of the remaining expected output to the error stream will be
created by Test::Builder's C<diag> function, B<Test::Builder::Tester>
provides a convience function C<test_diag> that you can use instead of
C<test_err>.

The C<test_diag> function prepends comment hashes and spacing to the
start and newlines to the end of the expected output passed to it and
adds it to the list of expected error output.  So, instead of writing

   test_err("# Couldn't open file");

you can write

   test_diag("Couldn't open file");

Remember that B<Test::Builder>'s diag function will not add newlines to
the end of output and test_diag will. So to check

   Test::Builder->new->diag("foo\n","bar\n");

You would do

  test_diag("foo","bar")

without the newlines.

=cut

sub test_diag
{
    # do we need to do any setup?
    _start_testing() unless $testing;

    # expect the same thing, but prepended with "#     "
    local $_;
    $err->expect(map {"# $_"} @_)
}

=item test_test

Actually performs the output check testing the tests, comparing the
data (with C<eq>) that we have captured from B<Test::Builder> against
that that was declared with C<test_out> and C<test_err>.

This takes name/value pairs that effect how the test is run.

=over

=item title (synonym 'name', 'label')

The name of the test that will be displayed after the C<ok> or C<not
ok>.

=item skip_out

Setting this to a true value will cause the test to ignore if the
output sent by the test to the output stream does not match that
declared with C<test_out>.

=item skip_err

Setting this to a true value will cause the test to ignore if the
output sent by the test to the error stream does not match that
declared with C<test_err>.

=back

As a convience, if only one argument is passed then this argument
is assumed to be the name of the test (as in the above examples.)

Once C<test_test> has been run test output will be redirected back to
the original filehandles that B<Test::Builder> was connected to
(probably STDOUT and STDERR,) meaning any further tests you run
will function normally and cause success/errors for B<Test::Harness>.

=cut

sub test_test
{
   # decode the arguements as described in the pod
   my $mess;
   my %args;
   if (@_ == 1)
     { $mess = shift }
   else
   {
     %args = @_;
     $mess = $args{name} if exists($args{name});
     $mess = $args{title} if exists($args{title});
     $mess = $args{label} if exists($args{label});
   }

    # er, are we testing?
    croak "Not testing.  You must declare output with a test function first."
	unless $testing;

    # okay, reconnect the test suite back to the saved handles
    $t->output($original_output_handle);
    $t->failure_output($original_failure_handle);
    $t->todo_output($original_todo_handle);

    # restore the test no, etc, back to the original point
    $t->current_test($testing_num);
    $testing = 0;

    # re-enable the original setting of the harness
    $ENV{HARNESS_ACTIVE} = $original_harness_env;

    # check the output we've stashed
    unless ($t->ok(    ($args{skip_out} || $out->check)
                    && ($args{skip_err} || $err->check),
                   $mess))
    {
      # test failed

      local $_;

      $t->diag(map {"$_\n"} $out->complaint)
	unless $args{skip_out} || $out->check;

      $t->diag(map {"$_\n"} $err->complaint)
	unless $args{skip_err} || $err->check;
    }
}

=item line_num

A utility function that returns the line number that the function was
called on.  You can pass it an offset which will be added to the
result.  This is very useful for working out the correct text of
diagnostic functions that contain line numbers.

Essentially this is the same as the C<__LINE__> macro, but the
C<line_num(+3)> idiom is arguably nicer.

=cut

sub line_num
{
    my ($package, $filename, $line) = caller;
    return $line + (shift() || 0); # prevent warnings
}

=back

In addition to the six exported functions there there exists one
function that can only be accessed with a fully qualified function
call.

=over 4

=item color

When C<test_test> is called and the output that your tests generate
does not match that which you declared, C<test_test> will print out
debug information showing the two conflicting versions.  As this
output itself is debug information it can be confusing which part of
the output is from C<test_test> and which was the original output from
your original tests.  Also, it may be hard to spot things like
extraneous whitespace at the end of lines that may cause your test to
fail even though the output looks similar.

To assist you, if you have the B<Term::ANSIColor> module installed
(which you should do by default from perl 5.005 onwards), C<test_test>
can colour the background of the debug information to disambiguate the
different types of output. The debug output will have it's background
coloured green and red.  The green part represents the text which is
the same between the executed and actual output, the red shows which
part differs.

The C<color> function determines if colouring should occur or not.
Passing it a true or false value will enable or disable colouring
respectively, and the function called with no argument will return the
current setting.

To enable colouring from the command line, you can use the
B<Text::Builder::Tester::Color> module like so:

   perl -Mlib=Text::Builder::Tester::Color test.t

Or by including the B<Test::Builder::Tester::Color> module directly in
the PERL5LIB.

=cut

my $color;
sub color
{
  $color = shift if @_;
  $color;
}

=back

=head1 BUGS

Calls C<<Test::Builder->no_ending>> turning off the ending tests.
This is needed as otherwise it will trip out because we've run more
tests than we strictly should have and it'll register any failures we
had that we were testing for as real failures.

The color function doesn't work unless B<Term::ANSIColor> is installed
and is compatible with your terminal.

Bugs (and requests for new features) can be reported to the author
though the CPAN RT system:
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Builder-Tester>

=head1 AUTHOR

Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.

Some code taken from B<Test::More> and B<Test::Catch>, written by by
Michael G Schwern E<lt>schwern@pobox.comE<gt>.  Hence, those parts
Copyright Micheal G Schwern 2001.  Used and distributed with
permission.

This program is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.

=head1 NOTES

This code has been tested explicitly on the following versions
of perl: 5.7.3, 5.6.1, 5.6.0, 5.005_03, 5.004_05 and 5.004.

Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting
me use his testing system to try this module out on.

=head1 SEE ALSO

L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>.

=cut

1;

####################################################################
# Helper class that is used to remember expected and received data

package Test::Tester::Tie;

##
# add line(s) to be expected

sub expect
{
    my $self = shift;

    my @checks = @_;
    foreach my $check (@checks) {
        $check = $self->_translate_Failed_check($check);
        push @{$self->[2]}, ref $check ? $check : "$check\n";
    }
}


sub _translate_Failed_check 
{
    my($self, $check) = @_;

    if( $check =~ /\A(.*)#     (Failed .*test) \((.*?) at line (\d+)\)\z/ ) {
        $check = qr/\Q$1\E#\s+\Q$2\E.*?\n?.*?\Q$3\E at line \Q$4\E.*\n?/;
    }

    return $check;
}


##
# return true iff the expected data matches the got data

sub check
{
    my $self = shift;

    # turn off warnings as these might be undef
    local $^W = 0;

    my @checks = @{$self->[2]};
    my $got = $self->[1];
    foreach my $check (@checks) {
        $check = qr/^\Q$check\E/ unless ref $check;
        return 0 unless $got =~ s/^$check//;
    }

    return length $got == 0;
}

##
# a complaint message about the inputs not matching (to be
# used for debugging messages)

sub complaint
{
    my $self = shift;
    my $type   = $self->type;
    my $got    = $self->got;
    my $wanted = join '', @{$self->wanted};

    # are we running in colour mode?
    if (Test::Builder::Tester::color)
    {
      # get color
      eval "require Term::ANSIColor";
      unless ($@)
      {
	# colours

	my $green = Term::ANSIColor::color("black").
	            Term::ANSIColor::color("on_green");
        my $red   = Term::ANSIColor::color("black").
                    Term::ANSIColor::color("on_red");
	my $reset = Term::ANSIColor::color("reset");

	# work out where the two strings start to differ
	my $char = 0;
	$char++ while substr($got, $char, 1) eq substr($wanted, $char, 1);

	# get the start string and the two end strings
	my $start     = $green . substr($wanted, 0,   $char);
	my $gotend    = $red   . substr($got   , $char) . $reset;
	my $wantedend = $red   . substr($wanted, $char) . $reset;

	# make the start turn green on and off
	$start =~ s/\n/$reset\n$green/g;

	# make the ends turn red on and off
	$gotend    =~ s/\n/$reset\n$red/g;
	$wantedend =~ s/\n/$reset\n$red/g;

	# rebuild the strings
	$got    = $start . $gotend;
	$wanted = $start . $wantedend;
      }
    }

    return "$type is:\n" .
           "$got\nnot:\n$wanted\nas expected"
}

##
# forget all expected and got data

sub reset
{
    my $self = shift;
    @$self = ($self->[0], '', []);
}


sub got
{
    my $self = shift;
    return $self->[1];
}

sub wanted
{
    my $self = shift;
    return $self->[2];
}

sub type
{
    my $self = shift;
    return $self->[0];
}

###
# tie interface
###

sub PRINT  {
    my $self = shift;
    $self->[1] .= join '', @_;
}

sub TIEHANDLE {
    my($class, $type) = @_;

    my $self = bless [$type], $class;
    $self->reset;

    return $self;
}

sub READ {}
sub READLINE {}
sub GETC {}
sub FILENO {}

1;
Commit	Line	Data
845d7e37	1	package Test::Builder::Tester;
	2
	3	use strict;
	4	use vars qw(@EXPORT $VERSION @ISA);
68938d83	5	$VERSION = "1.03";
845d7e37	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
68938d83	21	test_fail(+1, "foo");
845d7e37	22	fail("foo");
	23	test_test("fail works");
	24
68938d83	25	test_pass("baz");
	26	ok(1, "baz");
	27	test_test("pass works");
	28
	29	test_fail(+3, "is foo bar?");
	30	test_err("# got: 'foo'",
	31	"# expected: 'bar'");
	32	is("foo", "bar", "is foo bar?");
	33	test_test("diagnostic checking works");
	34
	35
845d7e37	36	=head1 DESCRIPTION
	37
	38	A module that helps you test testing modules that are built with
	39	B<Test::Builder>.
	40
	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
68938d83	43	Test::Builder::Tester functions to declare what the testsuite you
68938d83	44	are testing will output with B<Test::Builder>.
845d7e37	45
	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.
	50
	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
	54	output.
	55
	56	=cut
	57
	58	####
	59	# set up testing
	60	####
	61
	62	my $t = Test::Builder->new;
	63
	64	###
	65	# make us an exporter
	66	###
	67
	68	use Exporter;
	69	@ISA = qw(Exporter);
	70
68938d83	71	@EXPORT = qw(test_out test_err test_fail test_diag test_test line_num test_pass);
845d7e37	72
	73	# _export_to_level and import stolen directly from Test::More. I am
	74	# the king of cargo cult programming ;-)
	75
	76	# 5.004's Exporter doesn't have export_to_level.
	77	sub _export_to_level
	78	{
	79	my $pkg = shift;
	80	my $level = shift;
	81	(undef) = shift; # XXX redundant arg
	82	my $callpkg = caller($level);
	83	$pkg->export($callpkg, @_);
	84	}
	85
	86	sub import {
	87	my $class = shift;
	88	my(@plan) = @_;
	89
	90	my $caller = caller;
	91
	92	$t->exported_to($caller);
	93	$t->plan(@plan);
	94
	95	my @imports = ();
	96	foreach my $idx (0..$#plan) {
	97	if( $plan[$idx] eq 'import' ) {
	98	@imports = @{$plan[$idx+1]};
	99	last;
	100	}
	101	}
	102
	103	__PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
	104	}
	105
	106	###
	107	# set up file handles
	108	###
	109
	110	# create some private file handles
	111	my $output_handle = gensym;
	112	my $error_handle = gensym;
	113
	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";
	117
	118	####
	119	# exported functions
	120	####
	121
	122	# for remembering that we're testing and where we're testing at
	123	my $testing = 0;
	124	my $testing_num;
	125
	126	# remembering where the file handles were originally connected
	127	my $original_output_handle;
	128	my $original_failure_handle;
	129	my $original_todo_handle;
	130
	131	my $original_test_number;
	132	my $original_harness_state;
	133
	134	my $original_harness_env;
	135
136	# function that starts testing and redirects the filehandles for now
137	sub _start_testing
138	{
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;
143
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();
148
149	# switch out to our own handles
150	$t->output($output_handle);
151	$t->failure_output($error_handle);
152	$t->todo_output($error_handle);
153
154	# clear the expected list
155	$out->reset();
156	$err->reset();
157
158	# remeber that we're testing
159	$testing = 1;
160	$testing_num = $t->current_test;
161	$t->current_test(0);
162
163	# look, we shouldn't do the ending stuff
164	$t->no_ending(1);
165	}
166
68938d83	167	=head2 Functions
845d7e37	168
68938d83	169	These are the functions exported by default.
845d7e37	170
	171	=over 4
	172
68938d83	173	=item test_pass
845d7e37	174
68938d83	175	test_pass();
68938d83	176	test_pass($description);
845d7e37	177
68938d83	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
	181	all the time like so
845d7e37	182
68938d83	183	test_out("ok 1 - some test name here");
845d7e37	184
68938d83	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.
845d7e37	188
68938d83	189	test_pass("some test name here");
845d7e37	190
	191	=cut
	192
68938d83	193	sub test_pass(;$)
845d7e37	194	{
68938d83	195	_start_testing() unless $testing++;
	196	my $mess = "ok $testing";
	197	$mess .= ' - ' . shift if @_;
	198	$out->expect( $mess, @_ );
845d7e37	199	}
845d7e37	200
845d7e37	201
	202	=item test_fail
	203
68938d83	204	test_fail($line_num_offset);
	205	test_fail($line_num_offset, $description);
	206
845d7e37	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
	211	so
	212
	213	test_err("# Failed test ($0 at line ".line_num(+1).")");
	214
68938d83	215	C<test_fail> exists as a convenience function that can be called
845d7e37	216	instead. It takes one argument, the offset from the current line that
	217	the line that causes the fail is on.
	218
	219	test_fail(+1);
68938d83	220	ok(0);
845d7e37	221
68938d83	222	It optionally takes the $description of the test.
845d7e37	223
68938d83	224	test_fail(+1, "kaboom");
68938d83	225	fail("kaboom");
845d7e37	226
	227	=cut
	228
	229	sub test_fail
	230	{
	231	# do we need to do any setup?
68938d83	232	_start_testing() unless $testing++;
845d7e37	233
	234	# work out what line we should be on
	235	my ($package, $filename, $line) = caller;
	236	$line = $line + (shift() \|\| 0); # prevent warnings
	237
68938d83	238	my $mess = "not ok $testing";
	239	$mess .= ' - ' . shift if @_;
	240	$out->expect( $mess );
	241
845d7e37	242	# expect that on stderr
	243	$err->expect("# Failed test ($0 at line $line)");
	244	}
	245
68938d83	246
	247	=item test_out
	248
	249	test_out(@output);
	250
	251	=item test_err
	252
	253	test_err(@diagnostic_output);
	254
	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
	258
	259	test_out("foo","bar");
	260
	261	is the same as
	262
	263	test_out("foo\nbar");
	264
	265	which is even the same as
	266
	267	test_out("foo");
	268	test_out("bar");
	269
	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
	274	call C<test_test>.
	275
	276	=cut
	277
	278	sub test_out(@)
	279	{
	280	# do we need to do any setup?
	281	_start_testing() unless $testing;
	282
	283	$out->expect(@_)
	284	}
	285
	286	sub test_err(@)
	287	{
	288	# do we need to do any setup?
	289	_start_testing() unless $testing;
	290
	291	$err->expect(@_)
	292	}
	293
	294
845d7e37	295	=item test_diag
	296
	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
	300	C<test_err>.
	301
	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
	305
	306	test_err("# Couldn't open file");
	307
	308	you can write
	309
	310	test_diag("Couldn't open file");
	311
	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
	314
	315	Test::Builder->new->diag("foo\n","bar\n");
	316
	317	You would do
	318
	319	test_diag("foo","bar")
	320
	321	without the newlines.
	322
	323	=cut
	324
	325	sub test_diag
	326	{
	327	# do we need to do any setup?
	328	_start_testing() unless $testing;
	329
	330	# expect the same thing, but prepended with "# "
	331	local $_;
	332	$err->expect(map {"# $_"} @_)
	333	}
	334
	335	=item test_test
	336
	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>.
	340
	341	This takes name/value pairs that effect how the test is run.
	342
	343	=over
	344
	345	=item title (synonym 'name', 'label')
	346
	347	The name of the test that will be displayed after the C<ok> or C<not
	348	ok>.
	349
	350	=item skip_out
	351
	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>.
	355
	356	=item skip_err
	357
	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>.
361
362	=back
363
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.)
366
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>.
371
372	=cut
373
374	sub test_test
375	{
376	# decode the arguements as described in the pod
377	my $mess;
378	my %args;
379	if (@_ == 1)
380	{ $mess = shift }
381	else
382	{
383	%args = @_;
384	$mess = $args{name} if exists($args{name});
385	$mess = $args{title} if exists($args{title});
386	$mess = $args{label} if exists($args{label});
387	}
388
389	# er, are we testing?
390	croak "Not testing. You must declare output with a test function first."
391	unless $testing;
392
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);
397
398	# restore the test no, etc, back to the original point
399	$t->current_test($testing_num);
400	$testing = 0;
401
402	# re-enable the original setting of the harness
403	$ENV{HARNESS_ACTIVE} = $original_harness_env;
404
405	# check the output we've stashed
406	unless ($t->ok( ($args{skip_out} \|\| $out->check)
407	&& ($args{skip_err} \|\| $err->check),
408	$mess))
409	{
845d7e37	410	# test failed
	411
	412	local $_;
	413
	414	$t->diag(map {"$_\n"} $out->complaint)
	415	unless $args{skip_out} \|\| $out->check;
	416
	417	$t->diag(map {"$_\n"} $err->complaint)
	418	unless $args{skip_err} \|\| $err->check;
	419	}
	420	}
	421
	422	=item line_num
	423
	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
68938d83	427	diagnostic functions that contain line numbers.
845d7e37	428
	429	Essentially this is the same as the C<__LINE__> macro, but the
	430	C<line_num(+3)> idiom is arguably nicer.
	431
	432	=cut
	433
	434	sub line_num
	435	{
	436	my ($package, $filename, $line) = caller;
	437	return $line + (shift() \|\| 0); # prevent warnings
	438	}
	439
	440	=back
	441
	442	In addition to the six exported functions there there exists one
	443	function that can only be accessed with a fully qualified function
	444	call.
	445
	446	=over 4
	447
	448	=item color
	449
	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.
	458
	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
	465	part differs.
	466
	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
	470	current setting.
	471
	472	To enable colouring from the command line, you can use the
	473	B<Text::Builder::Tester::Color> module like so:
	474
	475	perl -Mlib=Text::Builder::Tester::Color test.t
	476
	477	Or by including the B<Test::Builder::Tester::Color> module directly in
	478	the PERL5LIB.
	479
	480	=cut
	481
	482	my $color;
	483	sub color
	484	{
	485	$color = shift if @_;
	486	$color;
	487	}
	488
	489	=back
	490
	491	=head1 BUGS
492
68938d83	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.
845d7e37	497
	498	The color function doesn't work unless B<Term::ANSIColor> is installed
	499	and is compatible with your terminal.
	500
	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>
	504
	505	=head1 AUTHOR
	506
	507	Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
	508
	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
	512	permission.
	513
	514	This program is free software; you can redistribute it
	515	and/or modify it under the same terms as Perl itself.
	516
	517	=head1 NOTES
	518
	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.
	521
	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.
	524
	525	=head1 SEE ALSO
	526
	527	L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>.
	528
	529	=cut
	530
	531	1;
	532
	533	####################################################################
	534	# Helper class that is used to remember expected and received data
	535
	536	package Test::Tester::Tie;
	537
	538	##
	539	# add line(s) to be expected
	540
	541	sub expect
	542	{
	543	my $self = shift;
	544
	545	my @checks = @_;
	546	foreach my $check (@checks) {
	547	$check = $self->_translate_Failed_check($check);
	548	push @{$self->[2]}, ref $check ? $check : "$check\n";
	549	}
	550	}
	551
	552
	553	sub _translate_Failed_check
	554	{
	555	my($self, $check) = @_;
	556
	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?/;
	559	}
	560
561	return $check;
562	}
563
564
565	##
566	# return true iff the expected data matches the got data
567
568	sub check
569	{
570	my $self = shift;
571
572	# turn off warnings as these might be undef
573	local $^W = 0;
574
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//;
580	}
581
582	return length $got == 0;
583	}
584
585	##
586	# a complaint message about the inputs not matching (to be
587	# used for debugging messages)
588
589	sub complaint
590	{
591	my $self = shift;
592	my $type = $self->type;
593	my $got = $self->got;
68938d83	594	my $wanted = join '', @{$self->wanted};
845d7e37	595
	596	# are we running in colour mode?
	597	if (Test::Builder::Tester::color)
	598	{
	599	# get color
	600	eval "require Term::ANSIColor";
	601	unless ($@)
	602	{
	603	# colours
	604
	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");
	610
	611	# work out where the two strings start to differ
	612	my $char = 0;
	613	$char++ while substr($got, $char, 1) eq substr($wanted, $char, 1);
	614
	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;
	619
	620	# make the start turn green on and off
	621	$start =~ s/\n/$reset\n$green/g;
	622
	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;
	626
	627	# rebuild the strings
	628	$got = $start . $gotend;
	629	$wanted = $start . $wantedend;
	630	}
	631	}
	632
	633	return "$type is:\n" .
	634	"$got\nnot:\n$wanted\nas expected"
	635	}
	636
	637	##
	638	# forget all expected and got data
	639
	640	sub reset
	641	{
	642	my $self = shift;
	643	@$self = ($self->[0], '', []);
	644	}
	645
	646
	647	sub got
	648	{
	649	my $self = shift;
	650	return $self->[1];
	651	}
	652
	653	sub wanted
	654	{
	655	my $self = shift;
	656	return $self->[2];
	657	}
	658
659	sub type
660	{
661	my $self = shift;
662	return $self->[0];
663	}
664
665	###
666	# tie interface
667	###
668
669	sub PRINT {
670	my $self = shift;
671	$self->[1] .= join '', @_;
672	}
673
674	sub TIEHANDLE {
675	my($class, $type) = @_;
676
677	my $self = bless [$type], $class;
678	$self->reset;
679
680	return $self;
681	}
682
683	sub READ {}
684	sub READLINE {}
685	sub GETC {}
686	sub FILENO {}
687
688	1;