From: Steve Peters Date: Sun, 9 Oct 2005 15:24:43 +0000 (+0000) Subject: Upgrade to Test-Simple-0.62. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=845d7e37127991657355cc3e4fd6b4d012f8f30d;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Test-Simple-0.62. p4raw-id: //depot/perl@25718 --- diff --git a/MANIFEST b/MANIFEST index aa068f2..8df946e 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1958,6 +1958,8 @@ lib/Term/ReadLine.pm Stub readline library lib/Term/ReadLine.t See if Term::ReadLine works lib/Test/Builder.pm For writing new test libraries lib/Test/Builder/Module.pm Base class for test modules +lib/Test/Builder/Tester.pm For testing Test::Builder based classes +lib/Test/Builder/Tester/Color.pm Turn on color in Test::Builder::Tester lib/Test/Harness/Assert.pm Test::Harness::Assert (internal use only) lib/Test/Harness/bin/prove The prove harness utility lib/Test/Harness/Changes Test::Harness @@ -2040,6 +2042,13 @@ lib/Test/Simple/t/skipall.t Test::More test, skip all tests lib/Test/Simple/t/skip.t Test::More test, SKIP tests lib/Test/Simple/t/sort_bug.t Test::Simple test lib/Test/Simple/t/strays.t Test::Builder stray newline checks +lib/Test/Simple/t/tbt_01basic.t Test::Builder::Tester test +lib/Test/Simple/t/tbt_02fhrestore.t Test::Builder::Tester test +lib/Test/Simple/t/tbt_03die.t Test::Builder::Tester test +lib/Test/Simple/t/tbt_04line_num.t Test::Builder::Tester test +lib/Test/Simple/t/tbt_05faildiag.t Test::Builder::Tester test +lib/Test/Simple/t/tbt_06errormess.t Test::Builder::Tester test +lib/Test/Simple/t/tbt_07args.t Test::Builder::Tester test lib/Test/Simple/t/threads.t Test::Builder thread-safe checks lib/Test/Simple/t/thread_taint.t Test::Simple test lib/Test/Simple/t/todo.t Test::More test, TODO tests diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm index b107633..ac4a8a4 100644 --- a/lib/Test/Builder.pm +++ b/lib/Test/Builder.pm @@ -8,7 +8,7 @@ $^C ||= 0; use strict; use vars qw($VERSION); -$VERSION = '0.31'; +$VERSION = '0.32'; $VERSION = eval $VERSION; # make the alpha version come out as a number # Make Test::Builder thread-safe for ithreads. @@ -870,6 +870,8 @@ sub BAIL_OUT { =for deprecated BAIL_OUT() used to be BAILOUT() +=cut + *BAILOUT = \&BAIL_OUT; diff --git a/lib/Test/Builder/Module.pm b/lib/Test/Builder/Module.pm index b3ccce6..855488a 100644 --- a/lib/Test/Builder/Module.pm +++ b/lib/Test/Builder/Module.pm @@ -5,7 +5,7 @@ use Test::Builder; require Exporter; @ISA = qw(Exporter); -$VERSION = '0.02'; +$VERSION = '0.03'; use strict; diff --git a/lib/Test/Builder/Tester.pm b/lib/Test/Builder/Tester.pm new file mode 100644 index 0000000..9e3b9c7 --- /dev/null +++ b/lib/Test/Builder/Tester.pm @@ -0,0 +1,640 @@ +package Test::Builder::Tester; + +use strict; +use vars qw(@EXPORT $VERSION @ISA); +$VERSION = "1.02"; + +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_out("not ok 1 - foo"); + test_fail(+1); + fail("foo"); + test_test("fail works"); + +=head1 DESCRIPTION + +A module that helps you test testing modules that are built with +B. + +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 +C and C in advance to declare what the testsuite you +are testing will output with B to stdout and stderr. + +You then can run the test(s) from your test suite that call +B. At this point the output of B is +safely captured by B rather than being +interpreted as real test output. + +The final stage is to call C that will simply compare what you +predeclared to what B 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); + +# _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 Methods + +These are the six methods that are exported as default. + +=over 4 + +=item test_out + +=item test_err + +Procedures for predeclaring the output that your test suite is +expected to produce until C is called. These procedures +automatically assume that each line terminates with "\n". So + + test_out("ok 1","ok 2"); + +is the same as + + test_out("ok 1\nok 2"); + +which is even the same as + + test_out("ok 1"); + test_out("ok 2"); + +Once C or C (or C or C) have +been called once all further output from B will be +captured by B. This means that your will not +be able perform further tests to the normal output in the normal way +until you call C (well, unless you manually meddle with the +output filehandles) + +=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_fail + +Because the standard failure message that B 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 with the string all the time like +so + + test_err("# Failed test ($0 at line ".line_num(+1).")"); + +C exists as a convenience method 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); + +This means that the example in the synopsis could be rewritten +more simply as: + + test_out("not ok 1 - foo"); + test_fail(+1); + fail("foo"); + test_test("fail works"); + +=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 + + # expect that on stderr + $err->expect("# Failed test ($0 at line $line)"); +} + +=item test_diag + +As most of the remaining expected output to the error stream will be +created by Test::Builder's C function, B +provides a convience function C that you can use instead of +C. + +The C 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'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) that we have captured from B against +that that was declared with C and C. + +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 or C. + +=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. + +=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. + +=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 has been run test output will be redirected back to +the original filehandles that B was connected to +(probably STDOUT and STDERR,) meaning any further tests you run +will function normally and cause success/errors for B. + +=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)) + { + # print out the diagnostic information about why this + # 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 methods that contain line numbers. + +Essentially this is the same as the C<__LINE__> macro, but the +C 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 is called and the output that your tests generate +does not match that which you declared, C 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 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 module installed +(which you should do by default from perl 5.005 onwards), C +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 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 module like so: + + perl -Mlib=Text::Builder::Tester::Color test.t + +Or by including the B module directly in +the PERL5LIB. + +=cut + +my $color; +sub color +{ + $color = shift if @_; + $color; +} + +=back + +=head1 BUGS + +Calls B's C method 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 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 + +=head1 AUTHOR + +Copyright Mark Fowler Emark@twoshortplanks.comE 2002, 2004. + +Some code taken from B and B, written by by +Michael G Schwern Eschwern@pobox.comE. 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 Erichardc@unixbeard.netE for letting +me use his testing system to try this module out on. + +=head1 SEE ALSO + +L, L, L. + +=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 "\n", @{$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; diff --git a/lib/Test/Builder/Tester/Color.pm b/lib/Test/Builder/Tester/Color.pm new file mode 100644 index 0000000..b479e71 --- /dev/null +++ b/lib/Test/Builder/Tester/Color.pm @@ -0,0 +1,50 @@ +package Test::Builder::Tester::Color; + +use strict; + +require Test::Builder::Tester; + +=head1 NAME + +Test::Builder::Tester::Color - turn on colour in Test::Builder::Tester + +=head1 SYNOPSIS + + When running a test script + + perl -MTest::Builder::Tester::Color test.t + +=head1 DESCRIPTION + +Importing this module causes the subroutine color in Test::Builder::Tester +to be called with a true value causing colour highlighting to be turned +on in debug output. + +The sole purpose of this module is to enable colour highlighting +from the command line. + +=cut + +sub import +{ + Test::Builder::Tester::color(1); +} + +=head1 AUTHOR + +Copyright Mark Fowler Emark@twoshortplanks.comE 2002. + +This program is free software; you can redistribute it +and/or modify it under the same terms as Perl itself. + +=head1 BUGS + +This module will have no effect unless Term::ANSIColor is installed. + +=head1 SEE ALSO + +L, L + +=cut + +1; diff --git a/lib/Test/More.pm b/lib/Test/More.pm index c305dd0..8289ec0 100644 --- a/lib/Test/More.pm +++ b/lib/Test/More.pm @@ -16,7 +16,7 @@ sub _carp { use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); -$VERSION = '0.61'; +$VERSION = '0.62'; $VERSION = eval $VERSION; # make the alpha version come out as a number use Test::Builder::Module; @@ -765,6 +765,10 @@ is_deeply() compares the dereferenced values of references, the references themselves (except for their type) are ignored. This means aspects such as blessing and ties are not considered "different". +is_deeply() current has very limited handling of function reference +and globs. It merely checks if they have the same referent. This may +improve in the future. + Test::Differences and Test::Deep provide more in-depth functionality along these lines. @@ -862,7 +866,7 @@ sub _type { return '' if !ref $thing; - for my $type (qw(ARRAY HASH REF SCALAR GLOB Regexp)) { + for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) { return $type if UNIVERSAL::isa($thing, $type); } @@ -1250,6 +1254,10 @@ sub _deep_check { $ok = _deep_check($$e1, $$e2); pop @Data_Stack if $ok; } + elsif( $type ) { + push @Data_Stack, { type => $type, vals => [$e1, $e2] }; + $ok = 0; + } else { _whoa(1, "No type in _deep_check"); } diff --git a/lib/Test/Simple.pm b/lib/Test/Simple.pm index 74cb1fc..ccf3d60 100644 --- a/lib/Test/Simple.pm +++ b/lib/Test/Simple.pm @@ -4,7 +4,7 @@ use 5.004; use strict 'vars'; use vars qw($VERSION @ISA @EXPORT); -$VERSION = '0.61'; +$VERSION = '0.62'; $VERSION = eval $VERSION; # make the alpha version come out as a number use Test::Builder::Module; diff --git a/lib/Test/Simple/Changes b/lib/Test/Simple/Changes index 2f44ab6..3e0a1d7 100644 --- a/lib/Test/Simple/Changes +++ b/lib/Test/Simple/Changes @@ -1,3 +1,12 @@ +0.62 Sat Oct 8 01:25:03 PDT 2005 + * Aborbed Test::Builder::Tester. The last release broke it because its + screen scraping Test::More and the failure output changed. By + distributing them together we ensure TBT won't break again. + * Test::Builder->BAILOUT() was missing. + - is_deeply() can now handle function and code refs in a very limited + way. It simply looks to see if they have the same referent. + [rt.cpan.org 14746] + 0.61 Fri Sep 23 23:26:05 PDT 2005 - create.t was trying to read from a file before it had been closed (and thus the changes may not have yet been written). diff --git a/lib/Test/Simple/t/More.t b/lib/Test/Simple/t/More.t index 24141d9..1631895 100644 --- a/lib/Test/Simple/t/More.t +++ b/lib/Test/Simple/t/More.t @@ -7,7 +7,7 @@ BEGIN { } } -use Test::More tests => 48; +use Test::More tests => 51; # Make sure we don't mess with $@ or $!. Test at bottom. my $Err = "this should not be touched"; @@ -156,6 +156,16 @@ cmp_ok(0, '||', 1, ' ||'); } isa_ok( Wibble->new, 'Wibblemeister' ); +my $sub = sub {}; +is_deeply( $sub, $sub, 'the same function ref' ); + +use Symbol; +my $glob = gensym; +is_deeply( $glob, $glob, 'the same glob' ); + +is_deeply( { foo => $sub, bar => [1, $glob] }, + { foo => $sub, bar => [1, $glob] } + ); # These two tests must remain at the end. is( $@, $Err, '$@ untouched' ); diff --git a/lib/Test/Simple/t/bail_out.t b/lib/Test/Simple/t/bail_out.t index c05d028..d60c150 100644 --- a/lib/Test/Simple/t/bail_out.t +++ b/lib/Test/Simple/t/bail_out.t @@ -28,7 +28,7 @@ my $Test = Test::Builder->create; $Test->level(0); if( $] >= 5.005 ) { - $Test->plan(tests => 2); + $Test->plan(tests => 3); } else { $Test->plan(skip_all => @@ -47,3 +47,5 @@ Bail out! ROCKS FALL! EVERYONE DIES! OUT $Test->is_eq( $Exit_Code, 255 ); + +$Test->ok( $Test->can("BAILOUT"), "Backwards compat" ); diff --git a/lib/Test/Simple/t/is_deeply_fail.t b/lib/Test/Simple/t/is_deeply_fail.t index 48f3828..efbbddd 100644 --- a/lib/Test/Simple/t/is_deeply_fail.t +++ b/lib/Test/Simple/t/is_deeply_fail.t @@ -25,7 +25,7 @@ package main; my $TB = Test::Builder->create; -$TB->plan(tests => 67); +$TB->plan(tests => 73); # Utility testing functions. sub ok ($;$) { @@ -341,3 +341,33 @@ ERR $TB->skip("Needs overload.pm") for 1..3; } } + + +# rt.cpan.org 14746 +{ +# line 349 + ok !is_deeply( sub {"foo"}, sub {"bar"} ), 'function refs'; + is( $out, "not ok 27\n" ); + like( $err, < 9; +use Test::More; + +ok(1,"This is a basic test"); + +test_out("ok 1 - tested"); +ok(1,"tested"); +test_test("captured okay on basic"); + +test_out("ok 1 - tested"); +ok(1,"tested"); +test_test("captured okay again without changing number"); + +ok(1,"test unrelated to Test::Builder::Tester"); + +test_out("ok 1 - one"); +test_out("ok 2 - two"); +ok(1,"one"); +ok(2,"two"); +test_test("multiple tests"); + +test_out("not ok 1 - should fail"); +test_err("# Failed test ($0 at line 28)"); +test_err("# got: 'foo'"); +test_err("# expected: 'bar'"); +is("foo","bar","should fail"); +test_test("testing failing"); + + +test_out("not ok 1"); +test_out("not ok 2"); +test_fail(+2); +test_fail(+1); +fail(); fail(); +test_test("testing failing on the same line with no name"); + + +test_out("not ok 1 - name"); +test_out("not ok 2 - name"); +test_fail(+2); +test_fail(+1); +fail("name"); fail("name"); +test_test("testing failing on the same line with the same name"); + + +test_out("not ok 1 - name # TODO Something"); +test_err("# Failed (TODO) test ($0 at line 52)"); +TODO: { + local $TODO = "Something"; + fail("name"); +} +test_test("testing failing with todo"); + diff --git a/lib/Test/Simple/t/tbt_02fhrestore.t b/lib/Test/Simple/t/tbt_02fhrestore.t new file mode 100644 index 0000000..e373571 --- /dev/null +++ b/lib/Test/Simple/t/tbt_02fhrestore.t @@ -0,0 +1,58 @@ +#!/usr/bin/perl + +use Test::Builder::Tester tests => 4; +use Test::More; +use Symbol; + +# create temporary file handles that still point indirectly +# to the right place + +my $orig_o = gensym; +my $orig_t = gensym; +my $orig_f = gensym; + +tie *$orig_o, "My::Passthru", \*STDOUT; +tie *$orig_t, "My::Passthru", \*STDERR; +tie *$orig_f, "My::Passthru", \*STDERR; + +# redirect the file handles to somewhere else for a mo + +use Test::Builder; +my $t = Test::Builder->new(); + +$t->output($orig_o); +$t->failure_output($orig_f); +$t->todo_output($orig_t); + +# run a test + +test_out("ok 1 - tested"); +ok(1,"tested"); +test_test("standard test okay"); + +# now check that they were restored okay + +ok($orig_o == $t->output(), "output file reconnected"); +ok($orig_t == $t->todo_output(), "todo output file reconnected"); +ok($orig_f == $t->failure_output(), "failure output file reconnected"); + +##################################################################### + +package My::Passthru; + +sub PRINT { + my $self = shift; + my $handle = $self->[0]; + print $handle @_; +} + +sub TIEHANDLE { + my $class = shift; + my $self = [shift()]; + return bless $self, $class; +} + +sub READ {} +sub READLINE {} +sub GETC {} +sub FILENO {} diff --git a/lib/Test/Simple/t/tbt_03die.t b/lib/Test/Simple/t/tbt_03die.t new file mode 100644 index 0000000..b9dba80 --- /dev/null +++ b/lib/Test/Simple/t/tbt_03die.t @@ -0,0 +1,12 @@ +#!/usr/bin/perl + +use Test::Builder::Tester tests => 1; +use Test::More; + +eval { + test_test("foo"); +}; +like($@, + "/Not testing\. You must declare output with a test function first\./", + "dies correctly on error"); + diff --git a/lib/Test/Simple/t/tbt_04line_num.t b/lib/Test/Simple/t/tbt_04line_num.t new file mode 100644 index 0000000..9e8365a --- /dev/null +++ b/lib/Test/Simple/t/tbt_04line_num.t @@ -0,0 +1,8 @@ +#!/usr/bin/perl + +use Test::More tests => 3; +use Test::Builder::Tester; + +is(line_num(),6,"normal line num"); +is(line_num(-1),6,"line number minus one"); +is(line_num(+2),10,"line number plus two"); diff --git a/lib/Test/Simple/t/tbt_05faildiag.t b/lib/Test/Simple/t/tbt_05faildiag.t new file mode 100644 index 0000000..59ad721 --- /dev/null +++ b/lib/Test/Simple/t/tbt_05faildiag.t @@ -0,0 +1,44 @@ +#!/usr/bin/perl + +use Test::Builder::Tester tests => 5; +use Test::More; + +# test_fail + +test_out("not ok 1 - one"); +test_fail(+1); +ok(0,"one"); + +test_out("not ok 2 - two"); +test_fail(+2); + +ok(0,"two"); + +test_test("test fail"); + +test_fail(+2); +test_out("not ok 1 - one"); +ok(0,"one"); +test_test("test_fail first"); + +# test_diag + +use Test::Builder; +my $test = new Test::Builder; + +test_diag("this is a test string","so is this"); +$test->diag("this is a test string\n", "so is this\n"); +test_test("test diag"); + +test_diag("this is a test string","so is this"); +$test->diag("this is a test string\n"); +$test->diag("so is this\n"); +test_test("test diag multi line"); + +test_diag("this is a test string"); +test_diag("so is this"); +$test->diag("this is a test string\n"); +$test->diag("so is this\n"); +test_test("test diag multiple"); + + diff --git a/lib/Test/Simple/t/tbt_06errormess.t b/lib/Test/Simple/t/tbt_06errormess.t new file mode 100644 index 0000000..ed8ebf5 --- /dev/null +++ b/lib/Test/Simple/t/tbt_06errormess.t @@ -0,0 +1,120 @@ +#!/usr/bin/perl -w + +use Test::More tests => 8; +use Symbol; +use Test::Builder; +use Test::Builder::Tester; + +use strict; + +# argh! now we need to test the thing we're testing. Basically we need +# to pretty much reimplement the whole code again. This is very +# annoying but can't be avoided. And onwards with the cut and paste + +# My brain is melting. My brain is melting. ETOOMANYLAYERSOFTESTING + +# 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"; + +# ooooh, use the test suite +my $t = Test::Builder->new; + +# remember the testing outputs +my $original_output_handle; +my $original_failure_handle; +my $original_todo_handle; +my $original_harness_env; +my $testing_num; + +sub start_testing +{ + # remember what the handles were set to + $original_output_handle = $t->output(); + $original_failure_handle = $t->failure_output(); + $original_todo_handle = $t->todo_output(); + $original_harness_env = $ENV{HARNESS_ACTIVE}; + + # switch out to our own handles + $t->output($output_handle); + $t->failure_output($error_handle); + $t->todo_output($error_handle); + + $ENV{HARNESS_ACTIVE} = 0; + + # clear the expected list + $out->reset(); + $err->reset(); + + # remeber that we're testing + $testing_num = $t->current_test; + $t->current_test(0); +} + +# each test test is actually two tests. This is bad and wrong +# but makes blood come out of my ears if I don't at least simplify +# it a little this way + +sub my_test_test +{ + my $text = shift; + local $^W = 0; + + # reset the outputs + $t->output($original_output_handle); + $t->failure_output($original_failure_handle); + $t->todo_output($original_todo_handle); + $ENV{HARNESS_ACTIVE} = $original_harness_env; + + # reset the number of tests + $t->current_test($testing_num); + + # check we got the same values + my $got; + my $wanted; + + # stdout + $t->ok($out->check, "STDOUT $text"); + + # stderr + $t->ok($err->check, "STDERR $text"); +} + +#################################################################### +# Meta meta tests +#################################################################### + +# this is a quick test to check the hack that I've just implemented +# actually does a cut down version of Test::Builder::Tester + +start_testing(); +$out->expect("ok 1 - foo"); +pass("foo"); +my_test_test("basic meta meta test"); + +start_testing(); +$out->expect("not ok 1 - foo"); +$err->expect("# Failed test ($0 at line ".line_num(+1).")"); +fail("foo"); +my_test_test("basic meta meta test 2"); + +start_testing(); +$out->expect("ok 1 - bar"); +test_out("ok 1 - foo"); +pass("foo"); +test_test("bar"); +my_test_test("meta meta test with tbt"); + +start_testing(); +$out->expect("ok 1 - bar"); +test_out("not ok 1 - foo"); +test_err("# Failed test ($0 at line ".line_num(+1).")"); +fail("foo"); +test_test("bar"); +my_test_test("meta meta test with tbt2 "); + +#################################################################### diff --git a/lib/Test/Simple/t/tbt_07args.t b/lib/Test/Simple/t/tbt_07args.t new file mode 100644 index 0000000..846a21e --- /dev/null +++ b/lib/Test/Simple/t/tbt_07args.t @@ -0,0 +1,215 @@ +#!/usr/bin/perl -w + +use Test::More tests => 18; +use Symbol; +use Test::Builder; +use Test::Builder::Tester; + +use strict; + +# argh! now we need to test the thing we're testing. Basically we need +# to pretty much reimplement the whole code again. This is very +# annoying but can't be avoided. And onwards with the cut and paste + +# My brain is melting. My brain is melting. ETOOMANYLAYERSOFTESTING + +# 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"; + +# ooooh, use the test suite +my $t = Test::Builder->new; + +# remember the testing outputs +my $original_output_handle; +my $original_failure_handle; +my $original_todo_handle; +my $testing_num; +my $original_harness_env; + +sub start_testing +{ + # remember what the handles were set to + $original_output_handle = $t->output(); + $original_failure_handle = $t->failure_output(); + $original_todo_handle = $t->todo_output(); + $original_harness_env = $ENV{HARNESS_ACTIVE}; + + # switch out to our own handles + $t->output($output_handle); + $t->failure_output($error_handle); + $t->todo_output($error_handle); + + $ENV{HARNESS_ACTIVE} = 0; + + # clear the expected list + $out->reset(); + $err->reset(); + + # remeber that we're testing + $testing_num = $t->current_test; + $t->current_test(0); +} + +# each test test is actually two tests. This is bad and wrong +# but makes blood come out of my ears if I don't at least simplify +# it a little this way + +sub my_test_test +{ + my $text = shift; + local $^W = 0; + + # reset the outputs + $t->output($original_output_handle); + $t->failure_output($original_failure_handle); + $t->todo_output($original_todo_handle); + $ENV{HARNESS_ACTIVE} = $original_harness_env; + + # reset the number of tests + $t->current_test($testing_num); + + # check we got the same values + my $got; + my $wanted; + + # stdout + $t->ok($out->check, "STDOUT $text"); + + # stderr + $t->ok($err->check, "STDERR $text"); +} + +#################################################################### +# Meta meta tests +#################################################################### + +# this is a quick test to check the hack that I've just implemented +# actually does a cut down version of Test::Builder::Tester + +start_testing(); +$out->expect("ok 1 - foo"); +pass("foo"); +my_test_test("basic meta meta test"); + +start_testing(); +$out->expect("not ok 1 - foo"); +$err->expect("# Failed test ($0 at line ".line_num(+1).")"); +fail("foo"); +my_test_test("basic meta meta test 2"); + +start_testing(); +$out->expect("ok 1 - bar"); +test_out("ok 1 - foo"); +pass("foo"); +test_test("bar"); +my_test_test("meta meta test with tbt"); + +start_testing(); +$out->expect("ok 1 - bar"); +test_out("not ok 1 - foo"); +test_err("# Failed test ($0 at line ".line_num(+1).")"); +fail("foo"); +test_test("bar"); +my_test_test("meta meta test with tbt2 "); + +#################################################################### +# Actual meta tests +#################################################################### + +# set up the outer wrapper again +start_testing(); +$out->expect("ok 1 - bar"); + +# set up what the inner wrapper expects +test_out("ok 1 - foo"); + +# the actual test function that we are testing +ok("1","foo"); + +# test the name +test_test(name => "bar"); + +# check that passed +my_test_test("meta test name"); + +#################################################################### + +# set up the outer wrapper again +start_testing(); +$out->expect("ok 1 - bar"); + +# set up what the inner wrapper expects +test_out("ok 1 - foo"); + +# the actual test function that we are testing +ok("1","foo"); + +# test the name +test_test(title => "bar"); + +# check that passed +my_test_test("meta test title"); + +#################################################################### + +# set up the outer wrapper again +start_testing(); +$out->expect("ok 1 - bar"); + +# set up what the inner wrapper expects +test_out("ok 1 - foo"); + +# the actual test function that we are testing +ok("1","foo"); + +# test the name +test_test(label => "bar"); + +# check that passed +my_test_test("meta test title"); + +#################################################################### + +# set up the outer wrapper again +start_testing(); +$out->expect("ok 1 - bar"); + +# set up what the inner wrapper expects +test_out("not ok 1 - foo this is wrong"); +test_fail(+3); + +# the actual test function that we are testing +ok("0","foo"); + +# test that we got what we expect, ignoring our is wrong +test_test(skip_out => 1, name => "bar"); + +# check that that passed +my_test_test("meta test skip_out"); + +#################################################################### + +# set up the outer wrapper again +start_testing(); +$out->expect("ok 1 - bar"); + +# set up what the inner wrapper expects +test_out("not ok 1 - foo"); +test_err("this is wrong"); + +# the actual test function that we are testing +ok("0","foo"); + +# test that we got what we expect, ignoring err is wrong +test_test(skip_err => 1, name => "bar"); + +# diagnostics failing out +# check that that passed +my_test_test("meta test skip_err"); + +####################################################################