From: Michael G. Schwern Date: Wed, 17 Oct 2001 03:42:41 +0000 (-0400) Subject: Test::Simple 0.32 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=33459055ff280d2a3b935d256531a576b162ec79;p=p5sagit%2Fp5-mst-13.2.git Test::Simple 0.32 Message-ID: <20011017034241.A25038@blackrider> p4raw-id: //depot/perl@12472 --- diff --git a/MANIFEST b/MANIFEST index d195583..7887c58 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1169,6 +1169,7 @@ lib/Term/Complete.t See if Term::Complete works lib/Term/ReadLine.pm Stub readline library lib/termcap.pl Perl library supporting termcap usage lib/Test.pm A simple framework for writing test scripts +lib/Test/Builder.pm For writing new test libraries lib/Test/Harness.pm A test harness lib/Test/Harness/Changes Test::Harness lib/Test/Harness/t/base.t Test::Harness @@ -1177,20 +1178,31 @@ lib/Test/Harness/t/test-harness.t Test::Harness test lib/Test/More.pm More utilities for writing tests lib/Test/Simple.pm Basic utility for writing tests lib/Test/Simple/Changes Test::Simple changes +lib/Test/Simple/t/Builder.t Test::Builder tests lib/Test/Simple/t/exit.t Test::Simple test, exit codes lib/Test/Simple/t/extra.t Test::Simple test lib/Test/Simple/t/fail-like.t Test::More test, like() failures lib/Test/Simple/t/fail-more.t Test::More test, tests failing lib/Test/Simple/t/fail.t Test::Simple test, test failures +lib/Test/Simple/t/filehandles.t Test::Simple test, STDOUT can be played with +lib/Test/Simple/t/import.t Test::More test, importing functions +lib/Test/Simple/t/is_deeply.t Test::More test, is_deeply() lib/Test/Simple/t/missing.t Test::Simple test, missing tests lib/Test/Simple/t/More.t Test::More test, basic stuff +lib/Test/Simple/t/no_ending.t Test::Builder test, no_ending() +lib/Test/Simple/t/no_header.t Test::Builder test, no_header() lib/Test/Simple/t/no_plan.t Test::Simple test, forgot the plan +lib/Test/Simple/t/output.t Test::Builder test, output methods +lib/Test/Simple/t/plan.t Test::More test, plan() lib/Test/Simple/t/plan_is_noplan.t Test::Simple test, no_plan +lib/Test/Simple/t/plan_no_plan.t Test::More test, plan() w/no_plan +lib/Test/Simple/t/plan_skip_all.t Test::More test, plan() w/skip_all lib/Test/Simple/t/simple.t Test::Simple test, basic stuff lib/Test/Simple/t/skip.t Test::More test, SKIP tests lib/Test/Simple/t/skipall.t Test::More test, skip all tests lib/Test/Simple/t/todo.t Test::More test, TODO tests lib/Test/Simple/t/undef.t Test::More test, undefs don't cause warnings +lib/Test/Simple/t/use_ok.t Test::More test, use_ok() lib/Test/Simple/t/useing.t Test::More test, compile test lib/Test/t/fail.t See if Test works lib/Test/t/mix.t See if Test works @@ -1200,7 +1212,6 @@ lib/Test/t/skip.t See if Test works lib/Test/t/success.t See if Test works lib/Test/t/todo.t See if Test works lib/Test/Tutorial.pod A tutorial on writing tests -lib/Test/Utils.pm Utility module for Test::Simple/More lib/Text/Abbrev.pm An abbreviation table builder lib/Text/Abbrev.t Test Text::Abbrev lib/Text/Balanced.pm Text::Balanced @@ -2033,7 +2044,6 @@ t/lib/strict/refs Tests of "use strict 'refs'" for strict.t t/lib/strict/subs Tests of "use strict 'subs'" for strict.t t/lib/strict/vars Tests of "use strict 'vars'" for strict.t t/lib/Test/Simple/Catch.pm Utility module for testing Test::Simple -t/lib/Test/Simple/Catch/More.pm Utility module for testing Test::More t/lib/Test/Simple/sample_tests/death.plx for exit.t t/lib/Test/Simple/sample_tests/death_in_eval.plx for exit.t t/lib/Test/Simple/sample_tests/extras.plx for exit.t diff --git a/lib/Test/Builder.pm b/lib/Test/Builder.pm new file mode 100644 index 0000000..99ec519 --- /dev/null +++ b/lib/Test/Builder.pm @@ -0,0 +1,965 @@ +package Test::Builder; + +use 5.004; + +# $^C was only introduced in 5.005-ish. We do this to prevent +# use of uninitialized value warnings in older perls. +$^C ||= 0; + +use strict; +use vars qw($VERSION $CLASS); +$VERSION = 0.03; +$CLASS = __PACKAGE__; + +my $IsVMS = $^O eq 'VMS'; + +use vars qw($Level); +my @Test_Results = (); +my @Test_Details = (); +my($Test_Died) = 0; +my($Have_Plan) = 0; +my $Curr_Test = 0; + + +=head1 NAME + +Test::Builder - Backend for building test libraries + +=head1 SYNOPSIS + + package My::Test::Module; + use Test::Builder; + require Exporter; + @ISA = qw(Exporter); + @EXPORT = qw(ok); + + my $Test = Test::Builder->new; + $Test->output('my_logfile'); + + sub import { + my($self) = shift; + my $pack = caller; + + $Test->exported_to($pack); + $Test->plan(@_); + + $self->export_to_level(1, $self, 'ok'); + } + + sub ok { + my($test, $name) = @_; + + $Test->ok($test, $name); + } + + +=head1 DESCRIPTION + +I The interface will change. + +Test::Simple and Test::More have proven to be popular testing modules, +but they're not always flexible enough. Test::Builder provides the +a building block upon which to write your own test libraries. + +=head2 Construction + +=over 4 + +=item B + + my $Test = Test::Builder->new; + +Returns a Test::Builder object representing the current state of the +test. + +Since you only run one test per program, there is B +Test::Builder object. No matter how many times you call new(), you're +getting the same object. (This is called a singleton). + +=cut + +my $Test; +sub new { + my($class) = shift; + $Test ||= bless ['Move along, nothing to see here'], $class; + return $Test; +} + +=back + +=head2 Setting up tests + +These methods are for setting up tests and declaring how many there +are. You usually only want to call one of these methods. + +=over 4 + +=item B + + my $pack = $Test->exported_to; + $Test->exported_to($pack); + +Tells Test::Builder what package you exported your functions to. +This is important for getting TODO tests right. + +=cut + +my $Exported_To; +sub exported_to { + my($self, $pack) = @_; + + if( defined $pack ) { + $Exported_To = $pack; + } + return $Exported_To; +} + +=item B + + $Test->plan('no_plan'); + $Test->plan( skip_all => $reason ); + $Test->plan( tests => $num_tests ); + +A convenient way to set up your tests. Call this and Test::Builder +will print the appropriate headers and take the appropriate actions. + +If you call plan(), don't call any of the other methods below. + +=cut + +sub plan { + my($self, $cmd, $arg) = @_; + + return unless $cmd; + + if( $cmd eq 'no_plan' ) { + $self->no_plan; + } + elsif( $cmd eq 'skip_all' ) { + return $self->skip_all($arg); + } + elsif( $cmd eq 'tests' ) { + if( $arg ) { + return $self->expected_tests($arg); + } + elsif( !defined $arg ) { + die "Got an undefined number of tests. Looks like you tried to ". + "say how many tests you plan to run but made a mistake.\n"; + } + elsif( !$arg ) { + die "You said to run 0 tests! You've got to run something.\n"; + } + } +} + +=item B + + my $max = $Test->expected_tests; + $Test->expected_tests($max); + +Gets/sets the # of tests we expect this test to run and prints out +the appropriate headers. + +=cut + +my $Expected_Tests = 0; +sub expected_tests { + my($self, $max) = @_; + + if( defined $max ) { + $Expected_Tests = $max; + $Have_Plan = 1; + + $self->_print("1..$max\n") unless $self->no_header; + } + return $Expected_Tests; +} + + +=item B + + $Test->no_plan; + +Declares that this test will run an indeterminate # of tests. + +=cut + +my($No_Plan) = 0; +sub no_plan { + $No_Plan = 1; + $Have_Plan = 1; +} + +=item B + + $Test->skip_all; + $Test->skip_all($reason); + +Skips all the tests, using the given $reason. Exits immediately with 0. + +=cut + +my $Skip_All = 0; +sub skip_all { + my($self, $reason) = @_; + + my $out = "1..0"; + $out .= " # Skip $reason" if $reason; + $out .= "\n"; + + $Skip_All = 1; + + $self->_print($out) unless $self->no_header; + exit(0); +} + +=back + +=head2 Running tests + +These actually run the tests, analogous to the functions in +Test::More. + +$name is always optional. + +=over 4 + +=item B + + $Test->ok($test, $name); + +Your basic test. Pass if $test is true, fail if $test is false. Just +like Test::Simple's ok(). + +=cut + +sub ok { + my($self, $test, $name) = @_; + + unless( $Have_Plan ) { + die "You tried to run a test without a plan! Gotta have a plan.\n"; + } + + $Curr_Test++; + + $self->diag(<caller; + + my $todo = $self->todo($pack); + + my $out; + unless( $test ) { + $out .= "not "; + $Test_Results[$Curr_Test-1] = $todo ? 1 : 0; + } + else { + $Test_Results[$Curr_Test-1] = 1; + } + + $out .= "ok"; + $out .= " $Curr_Test" if $self->use_numbers; + + if( defined $name ) { + $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. + $out .= " - $name"; + } + + if( $todo ) { + my $what_todo = $todo; + $out .= " # TODO $what_todo"; + } + + $out .= "\n"; + + $self->_print($out); + + unless( $test ) { + my $msg = $todo ? "Failed (TODO)" : "Failed"; + $self->diag("$msg test ($file at line $line)\n"); + } + + return $test ? 1 : 0; +} + +=item B + + $Test->is_eq($got, $expected, $name); + +Like Test::More's is(). Checks if $got eq $expected. This is the +string version. + +=item B + + $Test->is_num($get, $expected, $name); + +Like Test::More's is(). Checks if $got == $expected. This is the +numeric version. + +=cut + +sub is_eq { + my $self = shift; + local $Level = $Level + 1; + return $self->_is('eq', @_); +} + +sub is_num { + my $self = shift; + local $Level = $Level + 1; + return $self->_is('==', @_); +} + +sub _is { + my($self, $type, $got, $expect, $name) = @_; + + my $test; + { + local $^W = 0; # so we can compare undef quietly + $test = $type eq 'eq' ? $got eq $expect + : $got == $expect; + } + local $Level = $Level + 1; + my $ok = $self->ok($test, $name); + + unless( $ok ) { + $got = defined $got ? "'$got'" : 'undef'; + $expect = defined $expect ? "'$expect'" : 'undef'; + $self->diag(sprintf < + + $Test->like($this, qr/$regex/, $name); + $Test->like($this, '/$regex/', $name); + +Like Test::More's like(). Checks if $this matches the given $regex. + +You'll want to avoid qr// if you want your tests to work before 5.005. + +=cut + +sub like { + my($self, $this, $regex, $name) = @_; + + local $Level = $Level + 1; + + my $ok = 0; + if( ref $regex eq 'Regexp' ) { + local $^W = 0; + $ok = $self->ok( $this =~ $regex ? 1 : 0, $name ); + } + # Check if it looks like '/foo/' + elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) { + local $^W = 0; + $ok = $self->ok( $this =~ /(?$opts)$re/ ? 1 : 0, $name ); + } + else { + $ok = $self->ok( 0, $name ); + + $self->diag("'$regex' doesn't look much like a regex to me."); + + return $ok; + } + + unless( $ok ) { + $this = defined $this ? "'$this'" : 'undef'; + $self->diag(sprintf < + + $Test->skip; + $Test->skip($why); + +Skips the current test, reporting $why. + +=cut + +sub skip { + my($self, $why) = @_; + $why ||= ''; + + unless( $Have_Plan ) { + die "You tried to run tests without a plan! Gotta have a plan.\n"; + } + + $Curr_Test++; + + $Test_Results[$Curr_Test-1] = 1; + + my $out = "ok"; + $out .= " $Curr_Test" if $self->use_numbers; + $out .= " # skip $why\n"; + + $Test->_print($out); + + return 1; +} + +=begin _unimplemented + +=item B + + $Test->skip_rest; + $Test->skip_rest($reason); + +Like skip(), only it skips all the rest of the tests you plan to run +and terminates the test. + +If you're running under no_plan, it skips once and terminates the +test. + +=end _unimplemented + +=back + + +=head2 Test style + +=over 4 + +=item B + + $Test->level($how_high); + +How far up the call stack should $Test look when reporting where the +test failed. + +Defaults to 1. + +Setting $Test::Builder::Level overrides. This is typically useful +localized: + + { + local $Test::Builder::Level = 2; + $Test->ok($test); + } + +=cut + +sub level { + my($self, $level) = @_; + + if( defined $level ) { + $Level = $level; + } + return $Level; +} + +$CLASS->level(1); + + +=item B + + $Test->use_numbers($on_or_off); + +Whether or not the test should output numbers. That is, this if true: + + ok 1 + ok 2 + ok 3 + +or this if false + + ok + ok + ok + +Most useful when you can't depend on the test output order, such as +when threads or forking is involved. + +Test::Harness will accept either, but avoid mixing the two styles. + +Defaults to on. + +=cut + +my $Use_Nums = 1; +sub use_numbers { + my($self, $use_nums) = @_; + + if( defined $use_nums ) { + $Use_Nums = $use_nums; + } + return $Use_Nums; +} + +=item B + + $Test->no_header($no_header); + +If set to true, no "1..N" header will be printed. + +=item B + + $Test->no_ending($no_ending); + +Normally, Test::Builder does some extra diagnostics when the test +ends. It also changes the exit code as described in Test::Simple. + +If this is true, none of that will be done. + +=cut + +my($No_Header, $No_Ending) = (0,0); +sub no_header { + my($self, $no_header) = @_; + + if( defined $no_header ) { + $No_Header = $no_header; + } + return $No_Header; +} + +sub no_ending { + my($self, $no_ending) = @_; + + if( defined $no_ending ) { + $No_Ending = $no_ending; + } + return $No_Ending; +} + + +=back + +=head2 Output + +Controlling where the test output goes. + +=over 4 + +=item B + + $Test->diag(@msgs); + +Prints out the given $message. Normally, it uses the failure_output() +handle, but if this is for a TODO test, the todo_output() handle is +used. + +Output will be indented and prepended with a # as not to interfere +with test output. + +We encourage using this rather than calling print directly. + +=cut + +sub diag { + my($self, @msgs) = @_; + + # Prevent printing headers when compiling (ie. -c) + return if $^C; + + # Escape each line with a #. + foreach (@msgs) { + s/^([^#])/# $1/; + s/\n([^#])/\n# $1/g; + } + + local $Level = $Level + 1; + my $fh = $self->todo ? $self->todo_output : $self->failure_output; + local($\, $", $,) = (undef, ' ', ''); + print $fh @msgs; +} + +=begin _private + +=item B<_print> + + $Test->_print(@msgs); + +Prints to the output() filehandle. + +=end _private + +=cut + +sub _print { + my($self, @msgs) = @_; + + # Prevent printing headers when only compiling. Mostly for when + # tests are deparsed with B::Deparse + return if $^C; + + local($\, $", $,) = (undef, ' ', ''); + my $fh = $self->output; + print $fh @msgs; +} + + +=item B + + $Test->output($fh); + $Test->output($file); + +Where normal "ok/not ok" test output should go. + +Defaults to STDOUT. + +=item B + + $Test->failure_output($fh); + $Test->failure_output($file); + +Where diagnostic output on test failures and diag() should go. + +Defaults to STDERR. + +=item B + + $Test->todo_output($fh); + $Test->todo_output($file); + +Where diagnostics about todo test failures and diag() should go. + +Defaults to STDOUT. + +=cut + +my($Out_FH, $Fail_FH, $Todo_FH); +sub output { + my($self, $fh) = @_; + + if( defined $fh ) { + $Out_FH = _new_fh($fh); + } + return $Out_FH; +} + +sub failure_output { + my($self, $fh) = @_; + + if( defined $fh ) { + $Fail_FH = _new_fh($fh); + } + return $Fail_FH; +} + +sub todo_output { + my($self, $fh) = @_; + + if( defined $fh ) { + $Todo_FH = _new_fh($fh); + } + return $Todo_FH; +} + +sub _new_fh { + my($file_or_fh) = shift; + + my $fh; + unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) { + $fh = do { local *FH }; + open $fh, ">$file_or_fh" or + die "Can't open test output log $file_or_fh: $!"; + } + else { + $fh = $file_or_fh; + } + + return $fh; +} + +unless( $^C ) { + # We dup STDOUT and STDERR so people can change them in their + # test suites while still getting normal test output. + open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!"; + open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!"; + _autoflush(\*TESTOUT); + _autoflush(\*TESTERR); + $CLASS->output(\*TESTOUT); + $CLASS->failure_output(\*TESTERR); + $CLASS->todo_output(\*TESTOUT); +} + +sub _autoflush { + my($fh) = shift; + my $old_fh = select $fh; + $| = 1; + select $old_fh; +} + + +=back + + +=head2 Test Status and Info + +=over 4 + +=item B + + my $curr_test = $Test->current_test; + $Test->current_test($num); + +Gets/sets the current test # we're on. + +You usually shouldn't have to set this. + +=cut + +sub current_test { + my($self, $num) = @_; + + if( defined $num ) { + $Curr_Test = $num; + } + return $Curr_Test; +} + + +=item B + + my @tests = $Test->summary; + +A simple summary of the tests so far. True for pass, false for fail. +This is a logical pass/fail, so todos are passes. + +Of course, test #1 is $tests[0], etc... + +=cut + +sub summary { + my($self) = shift; + + return @Test_Results; +} + +=item B
I + + my @tests = $Test->details; + +Like summary(), but with a lot more detail. + + $tests[$test_num - 1] = + { ok => is the test considered ok? + actual_ok => did it literally say 'ok'? + name => name of the test (if any) + type => 'skip' or 'todo' (if any) + reason => reason for the above (if any) + }; + +=item B + + my $todo_reason = $Test->todo; + my $todo_reason = $Test->todo($pack); + +todo() looks for a $TODO variable in your tests. If set, all tests +will be considered 'todo' (see Test::More and Test::Harness for +details). Returns the reason (ie. the value of $TODO) if running as +todo tests, false otherwise. + +todo() is pretty part about finding the right package to look for +$TODO in. It uses the exported_to() package to find it. If that's +not set, it's pretty good at guessing the right package to look at. + +Sometimes there is some confusion about where todo() should be looking +for the $TODO variable. If you want to be sure, tell it explicitly +what $pack to use. + +=cut + +sub todo { + my($self, $pack) = @_; + + $pack = $pack || $self->exported_to || $self->caller(1); + + no strict 'refs'; + return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} + : 0; +} + +=item B + + my $package = $Test->caller; + my($pack, $file, $line) = $Test->caller; + my($pack, $file, $line) = $Test->caller($height); + +Like the normal caller(), except it reports according to your level(). + +=cut + +sub caller { + my($self, $height) = @_; + $height ||= 0; + + my @caller = CORE::caller($self->level + $height + 1); + return wantarray ? @caller : $caller[0]; +} + +=back + +=cut + +=begin _private + +=over 4 + +=item B<_sanity_check> + + _sanity_check(); + +Runs a bunch of end of test sanity checks to make sure reality came +through ok. If anything is wrong it will die with a fairly friendly +error message. + +=cut + +#'# +sub _sanity_check { + _whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!'); + _whoa(!$Have_Plan and $Curr_Test, + 'Somehow your tests ran without a plan!'); + _whoa($Curr_Test != @Test_Results, + 'Somehow you got a different number of results than tests ran!'); +} + +=item B<_whoa> + + _whoa($check, $description); + +A sanity check, similar to assert(). If the $check is true, something +has gone horribly wrong. It will die with the given $description and +a note to contact the author. + +=cut + +sub _whoa { + my($check, $desc) = @_; + if( $check ) { + die < + + _my_exit($exit_num); + +Perl seems to have some trouble with exiting inside an END block. 5.005_03 +and 5.6.1 both seem to do odd things. Instead, this function edits $? +directly. It should ONLY be called from inside an END block. It +doesn't actually exit, that's your job. + +=cut + +sub _my_exit { + $? = $_[0]; + + return 1; +} + + +=back + +=end _private + +=cut + +$SIG{__DIE__} = sub { + # We don't want to muck with death in an eval, but $^S isn't + # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing + # with it. Instead, we use caller. This also means it runs under + # 5.004! + my $in_eval = 0; + for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) { + $in_eval = 1 if $sub =~ /^\(eval\)/; + } + $Test_Died = 1 unless $in_eval; +}; + +sub _ending { + my $self = shift; + + _sanity_check(); + + # Bailout if plan() was never called. This is so + # "require Test::Simple" doesn't puke. + do{ _my_exit(0) && return } if !$Have_Plan; + + # Figure out if we passed or failed and print helpful messages. + if( @Test_Results ) { + # The plan? We have no plan. + if( $No_Plan ) { + $self->_print("1..$Curr_Test\n") unless $self->no_header; + $Expected_Tests = $Curr_Test; + } + + my $num_failed = grep !$_, @Test_Results[0..$Expected_Tests-1]; + $num_failed += abs($Expected_Tests - @Test_Results); + + if( $Curr_Test < $Expected_Tests ) { + $self->diag(<<"FAIL"); +# Looks like you planned $Expected_Tests tests but only ran $Curr_Test. +FAIL + } + elsif( $Curr_Test > $Expected_Tests ) { + my $num_extra = $Curr_Test - $Expected_Tests; + $self->diag(<<"FAIL"); +# Looks like you planned $Expected_Tests tests but ran $num_extra extra. +FAIL + } + elsif ( $num_failed ) { + $self->diag(<<"FAIL"); +# Looks like you failed $num_failed tests of $Expected_Tests. +FAIL + } + + if( $Test_Died ) { + $self->diag(<<"FAIL"); +# Looks like your test died just after $Curr_Test. +FAIL + + _my_exit( 255 ) && return; + } + + _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return; + } + elsif ( $Skip_All ) { + _my_exit( 0 ) && return; + } + else { + $self->diag("# No tests run!\n"); + _my_exit( 255 ) && return; + } +} + +END { + $Test->_ending if defined $Test and !$Test->no_ending; +} + +=head1 EXAMPLES + +At this point, Test::Simple and Test::More are your best examples. + +=head1 AUTHOR + +Original code by chromatic, maintained by Michael G Schwern +Eschwern@pobox.comE + +=head1 SEE ALSO + +Test::Simple, Test::More, Test::Harness + +=cut + +1; diff --git a/lib/Test/More.pm b/lib/Test/More.pm index 92d1d88..038122a 100644 --- a/lib/Test/More.pm +++ b/lib/Test/More.pm @@ -3,54 +3,35 @@ package Test::More; use 5.004; use strict; -use Carp; -use Test::Utils; +use Test::Builder; -BEGIN { - require Test::Simple; - *TESTOUT = \*Test::Simple::TESTOUT; - *TESTERR = \*Test::Simple::TESTERR; + +# Can't use Carp because it might cause use_ok() to accidentally succeed +# even though the module being used forgot to use Carp. Yes, this +# actually happened. +sub _carp { + my($file, $line) = (caller(1))[1,2]; + warn @_, sprintf " at $file line $line\n"; } + + require Exporter; -use vars qw($VERSION @ISA @EXPORT $TODO); -$VERSION = '0.19'; +use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); +$VERSION = '0.32'; @ISA = qw(Exporter); @EXPORT = qw(ok use_ok require_ok - is isnt like + is isnt like is_deeply skip todo pass fail eq_array eq_hash eq_set - skip $TODO plan can_ok isa_ok ); +my $Test = Test::Builder->new; -sub import { - my($class, $plan, @args) = @_; - - if( defined $plan ) { - if( $plan eq 'skip_all' ) { - $Test::Simple::Skip_All = 1; - my $out = "1..0"; - $out .= " # Skip @args" if @args; - $out .= "\n"; - - my_print *TESTOUT, $out; - exit(0); - } - else { - Test::Simple->import($plan => @args); - } - } - else { - Test::Simple->import; - } - - __PACKAGE__->_export_to_level(1, __PACKAGE__); -} # 5.004's Exporter doesn't have export_to_level. sub _export_to_level @@ -85,6 +66,8 @@ Test::More - yet another framework for writing test scripts isnt($this, $that, $test_name); like($this, qr/that/, $test_name); + is_deeply($complex_structure1, $complex_structure2, $test_name); + SKIP: { skip $why, $how_many unless $have_some_feature; @@ -152,6 +135,54 @@ Your script will declare a skip with the reason why you skipped and exit immediately with a zero (success). See L for details. +If you want to control what functions Test::More will export, you +have to use the 'import' option. For example, to import everything +but 'fail', you'd do: + + use Test::More tests => 23, import => ['!fail']; + +Alternatively, you can use the plan() function. Useful for when you +have to calculate the number of tests. + + use Test::More; + plan tests => keys %Stuff * 3; + +or for deciding between running the tests at all: + + use Test::More; + if( $^O eq 'MacOS' ) { + plan skip_all => 'Test irrelevent on MacOS'; + } + else { + plan tests => 42; + } + +=cut + +sub plan { + my(@plan) = @_; + + my $caller = caller; + + $Test->exported_to($caller); + $Test->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); +} + +sub import { + my($class) = shift; + goto &plan; +} + =head2 Test names @@ -220,7 +251,10 @@ This is actually Test::Simple's ok() routine. =cut -# We get ok() from Test::Simple's import(). +sub ok ($;$) { + my($test, $name) = @_; + $Test->ok($test, $name); +} =item B @@ -282,27 +316,7 @@ function which is an alias of isnt(). =cut sub is ($$;$) { - my($this, $that, $name) = @_; - - my $test; - { - local $^W = 0; # so is(undef, undef) works quietly. - $test = $this eq $that; - } - my $ok = @_ == 3 ? ok($test, $name) - : ok($test); - - unless( $ok ) { - $this = defined $this ? "'$this'" : 'undef'; - $that = defined $that ? "'$that'" : 'undef'; - my_print *TESTERR, sprintf <is_eq(@_); } sub isnt ($$;$) { @@ -314,15 +328,14 @@ sub isnt ($$;$) { $test = $this ne $that; } - my $ok = @_ == 3 ? ok($test, $name) - : ok($test); + my $ok = $Test->ok($test, $name); unless( $ok ) { $that = defined $that ? "'$that'" : 'undef'; - my_print *TESTERR, sprintf <diag(sprintf <like(@_); } =item B @@ -430,7 +408,7 @@ sub can_ok ($@) { my @nok = (); foreach my $method (@methods) { - my $test = "$class->can('$method')"; + my $test = "'$class'->can('$method')"; eval $test || push @nok, $method; } @@ -438,16 +416,16 @@ sub can_ok ($@) { $name = @methods == 1 ? "$class->can($methods[0])" : "$class->can(...)"; - ok( !@nok, $name ); + my $ok = $Test->ok( !@nok, $name ); - my_print *TESTERR, map "# $class->can('$_') failed\n", @nok; + $Test->diag(map "$class->can('$_') failed\n", @nok); - return !@nok; + return $ok; } =item B - isa_ok($object, $class); + isa_ok($object, $class, $object_name); Checks to see if the given $object->isa($class). Also checks to make sure the object was defined in the first place. Handy for this sort @@ -463,32 +441,38 @@ where you'd otherwise have to write to safeguard against your test script blowing up. +The diagnostics of this test normally just refer to 'the object'. If +you'd like them to be more specific, you can supply an $object_name +(for example 'Test customer'). + =cut -sub isa_ok ($$) { - my($object, $class) = @_; +sub isa_ok ($$;$) { + my($object, $class, $obj_name) = @_; my $diag; - my $name = "object->isa('$class')"; + $obj_name = 'The object' unless defined $obj_name; + my $name = "$obj_name isa $class"; if( !defined $object ) { - $diag = "The object isn't defined"; + $diag = "$obj_name isn't defined"; } elsif( !ref $object ) { - $diag = "The object isn't a reference"; + $diag = "$obj_name isn't a reference"; } elsif( !$object->isa($class) ) { - $diag = "The object isn't a '$class'"; + $diag = "$obj_name isn't a '$class'"; } + my $ok; if( $diag ) { - ok( 0, $name ); - my_print *TESTERR, "# $diag\n"; - return 0; + $ok = $Test->ok( 0, $name ); + $Test->diag("$diag\n"); } else { - ok( 1, $name ); - return 1; + $ok = $Test->ok( 1, $name ); } + + return $ok; } @@ -510,15 +494,11 @@ Use these very, very, very sparingly. =cut sub pass (;$) { - my($name) = @_; - return @_ == 1 ? ok(1, $name) - : ok(1); + $Test->ok(1, @_); } sub fail (;$) { - my($name) = @_; - return @_ == 1 ? ok(0, $name) - : ok(0); + $Test->ok(0, @_); } =back @@ -564,13 +544,13 @@ require $module; $module->import(\@imports); USE - my $ok = ok( !$@, "use $module;" ); + my $ok = $Test->ok( !$@, "use $module;" ); unless( $ok ) { chomp $@; - my_print *TESTERR, <diag(<ok( !$@, "require $module;" ); unless( $ok ) { chomp $@; - my_print *TESTERR, <diag(<). +you're using C, in which case you can leave $how_many off if +you like). You'll typically use this when a feature is missing, like an optional module is not installed or the operating system doesn't have some @@ -673,15 +654,16 @@ See L #'# sub skip { my($why, $how_many) = @_; - unless( $how_many >= 1 ) { + + unless( defined $how_many ) { # $how_many can only be avoided when no_plan is in use. - carp "skip() needs to know \$how_many tests are in the block" - if $Test::Simple::Planned_Tests; + _carp "skip() needs to know \$how_many tests are in the block" + unless $Test::Builder::No_Plan; $how_many = 1; } for( 1..$how_many ) { - Test::Simple::_skipped($why); + $Test->skip($why); } local $^W = 0; @@ -738,6 +720,83 @@ quite sure what will happen with filehandles. =over 4 +=item B + + is_deeply( $this, $that, $test_name ); + +Similar to is(), except that if $this and $that are hash or array +references, it does a deep comparison walking each data structure to +see if they are equivalent. If the two structures are different, it +will display the place where they start differing. + +B Display of scalar refs is not quite 100% + +=cut + +use vars qw(@Data_Stack); +my $DNE = bless [], 'Does::Not::Exist'; +sub is_deeply { + my($this, $that, $name) = @_; + + my $ok; + if( !ref $this || !ref $that ) { + $ok = $Test->is_eq($this, $that, $name); + } + else { + local @Data_Stack = (); + if( _deep_check($this, $that) ) { + $ok = $Test->ok(1, $name); + } + else { + $ok = $Test->ok(0, $name); + $ok = $Test->diag(_format_stack(@Data_Stack)); + } + } + + return $ok; +} + +sub _format_stack { + my(@Stack) = @_; + + my $var = '$FOO'; + my $did_arrow = 0; + foreach my $entry (@Stack) { + my $type = $entry->{type} || ''; + my $idx = $entry->{'idx'}; + if( $type eq 'HASH' ) { + $var .= "->" unless $did_arrow++; + $var .= "{$idx}"; + } + elsif( $type eq 'ARRAY' ) { + $var .= "->" unless $did_arrow++; + $var .= "[$idx]"; + } + elsif( $type eq 'REF' ) { + $var = "\${$var}"; + } + } + + my @vals = @{$Stack[-1]{vals}}[0,1]; + my @vars = (); + ($vars[0] = $var) =~ s/\$FOO/ \$got/; + ($vars[1] = $var) =~ s/\$FOO/\$expected/; + + my $out = "Structures begin differing at:\n"; + foreach my $idx (0..$#vals) { + my $val = $vals[$idx]; + $vals[$idx] = !defined $val ? 'undef' : + $val eq $DNE ? "Does not exist" + : "'$val'"; + } + + $out .= "$vars[0] = $vals[0]\n"; + $out .= "$vars[1] = $vals[1]\n"; + + return $out; +} + + =item B eq_array(\@this, \@that); @@ -750,13 +809,18 @@ multi-level structures are handled correctly. #'# sub eq_array { my($a1, $a2) = @_; - return 0 unless @$a1 == @$a2; return 1 if $a1 eq $a2; my $ok = 1; - for (0..$#{$a1}) { - my($e1,$e2) = ($a1->[$_], $a2->[$_]); + my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; + for (0..$max) { + my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; + my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; + + push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; $ok = _deep_check($e1,$e2); + pop @Data_Stack if $ok; + last unless $ok; } return $ok; @@ -785,7 +849,21 @@ sub _deep_check { { $ok = eq_hash($e1, $e2); } + elsif( UNIVERSAL::isa($e1, 'REF') and + UNIVERSAL::isa($e2, 'REF') ) + { + push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; + $ok = _deep_check($$e1, $$e2); + pop @Data_Stack if $ok; + } + elsif( UNIVERSAL::isa($e1, 'SCALAR') and + UNIVERSAL::isa($e2, 'SCALAR') ) + { + push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; + $ok = _deep_check($$e1, $$e2); + } else { + push @Data_Stack, { vals => [$e1, $e2] }; $ok = 0; } } @@ -806,13 +884,18 @@ is a deep check. sub eq_hash { my($a1, $a2) = @_; - return 0 unless keys %$a1 == keys %$a2; return 1 if $a1 eq $a2; my $ok = 1; - foreach my $k (keys %$a1) { - my($e1, $e2) = ($a1->{$k}, $a2->{$k}); + my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; + foreach my $k (keys %$bigger) { + my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; + my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; + + push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; $ok = _deep_check($e1, $e2); + pop @Data_Stack if $ok; + last unless $ok; } diff --git a/lib/Test/Simple.pm b/lib/Test/Simple.pm index f72f393..b314ed5 100644 --- a/lib/Test/Simple.pm +++ b/lib/Test/Simple.pm @@ -3,86 +3,23 @@ package Test::Simple; use 5.004; use strict 'vars'; -use Test::Utils; - use vars qw($VERSION); +$VERSION = '0.32'; -$VERSION = '0.19'; - -my(@Test_Results) = (); -my($Num_Tests, $Planned_Tests, $Test_Died) = (0,0,0); -my($Have_Plan) = 0; -my $IsVMS = $^O eq 'VMS'; +use Test::Builder; +my $Test = Test::Builder->new; - -# I'd like to have Test::Simple interfere with the program being -# tested as little as possible. This includes using Exporter or -# anything else (including strict). sub import { - # preserve caller() - if( @_ > 1 ) { - if( $_[1] eq 'no_plan' ) { - goto &no_plan; - } - else { - goto &plan - } - } -} - -sub plan { - my($class, %config) = @_; - - if( !exists $config{tests} ) { - die "You have to tell $class how many tests you plan to run.\n". - " use $class tests => 42; for example.\n"; - } - elsif( !defined $config{tests} ) { - die "Got an undefined number of tests. Looks like you tried to tell ". - "$class how many tests you plan to run but made a mistake.\n"; - } - elsif( !$config{tests} ) { - die "You told $class you plan to run 0 tests! You've got to run ". - "something.\n"; - } - else { - $Planned_Tests = $config{tests}; - } - - $Have_Plan = 1; - - my_print *TESTOUT, "1..$Planned_Tests\n"; - - no strict 'refs'; - my($caller) = caller; + my $self = shift; + my $caller = caller; *{$caller.'::ok'} = \&ok; - -} - -sub no_plan { - $Have_Plan = 1; - - my($caller) = caller; - no strict 'refs'; - *{$caller.'::ok'} = \&ok; + $Test->exported_to($caller); + $Test->plan(@_); } -unless( $^C ) { - $| = 1; - open(*TESTOUT, ">&STDOUT") or _whoa(1, "Can't dup STDOUT!"); - open(*TESTERR, ">&STDOUT") or _whoa(1, "Can't dup STDOUT!"); - { - my $orig_fh = select TESTOUT; - $| = 1; - select TESTERR; - $| = 1; - select $orig_fh; - } -} - =head1 NAME Test::Simple - Basic utilities for writing tests. @@ -147,82 +84,7 @@ will do what you mean (fail if stuff is empty) =cut sub ok ($;$) { - my($test, $name) = @_; - - unless( $Have_Plan ) { - die "You tried to use ok() without a plan! Gotta have a plan.\n". - " use Test::Simple tests => 23; for example.\n"; - } - - $Num_Tests++; - - my_print *TESTERR, < 23; for example.\n"; - } - - $Num_Tests++; - - # XXX Set this to "Skip" instead? - $Test_Results[$Num_Tests-1] = 1; - - # We must print this all in one shot or else it will break on VMS - my $msg; - $msg .= "ok $Num_Tests # skip $why\n"; - - my_print *TESTOUT, $msg; - - return 1; + $Test->ok(@_); } @@ -249,142 +111,6 @@ So the exit codes are... If you fail more than 254 tests, it will be reported as 254. -=begin _private - -=over 4 - -=item B<_sanity_check> - - _sanity_check(); - -Runs a bunch of end of test sanity checks to make sure reality came -through ok. If anything is wrong it will die with a fairly friendly -error message. - -=cut - -#'# -sub _sanity_check { - _whoa($Num_Tests < 0, 'Says here you ran a negative number of tests!'); - _whoa(!$Have_Plan and $Num_Tests, - 'Somehow your tests ran without a plan!'); - _whoa($Num_Tests != @Test_Results, - 'Somehow you got a different number of results than tests ran!'); -} - -=item B<_whoa> - - _whoa($check, $description); - -A sanity check, similar to assert(). If the $check is true, something -has gone horribly wrong. It will die with the given $description and -a note to contact the author. - -=cut - -sub _whoa { - my($check, $desc) = @_; - if( $check ) { - die < - - _my_exit($exit_num); - -Perl seems to have some trouble with exiting inside an END block. 5.005_03 -and 5.6.1 both seem to do odd things. Instead, this function edits $? -directly. It should ONLY be called from inside an END block. It -doesn't actually exit, that's your job. - -=cut - -sub _my_exit { - $? = $_[0]; - - return 1; -} - - -=back - -=end _private - -=cut - -$SIG{__DIE__} = sub { - # We don't want to muck with death in an eval, but $^S isn't - # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing - # with it. Instead, we use caller. This also means it runs under - # 5.004! - my $in_eval = 0; - for( my $stack = 1; my $sub = (caller($stack))[3]; $stack++ ) { - $in_eval = 1 if $sub =~ /^\(eval\)/; - } - $Test_Died = 1 unless $in_eval; -}; - -END { - _sanity_check(); - - # Bailout if import() was never called. This is so - # "require Test::Simple" doesn't puke. - do{ _my_exit(0) && return } if !$Have_Plan and !$Num_Tests; - - # Figure out if we passed or failed and print helpful messages. - if( $Num_Tests ) { - # The plan? We have no plan. - unless( $Planned_Tests ) { - my_print *TESTOUT, "1..$Num_Tests\n"; - $Planned_Tests = $Num_Tests; - } - - my $num_failed = grep !$_, @Test_Results[0..$Planned_Tests-1]; - $num_failed += abs($Planned_Tests - @Test_Results); - - if( $Num_Tests < $Planned_Tests ) { - my_print *TESTERR, <<"FAIL"; -# Looks like you planned $Planned_Tests tests but only ran $Num_Tests. -FAIL - } - elsif( $Num_Tests > $Planned_Tests ) { - my $num_extra = $Num_Tests - $Planned_Tests; - my_print *TESTERR, <<"FAIL"; -# Looks like you planned $Planned_Tests tests but ran $num_extra extra. -FAIL - } - elsif ( $num_failed ) { - my_print *TESTERR, <<"FAIL"; -# Looks like you failed $num_failed tests of $Planned_Tests. -FAIL - } - - if( $Test_Died ) { - my_print *TESTERR, <<"FAIL"; -# Looks like your test died just after $Num_Tests. -FAIL - - _my_exit( 255 ) && return; - } - - _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return; - } - elsif ( $Test::Simple::Skip_All ) { - _my_exit( 0 ) && return; - } - else { - my_print *TESTERR, "# No tests run!\n"; - _my_exit( 255 ) && return; - } -} - - -=pod - This module is by no means trying to be a complete testing system. Its just to get you started. Once you're off the ground its recommended you look at L. diff --git a/lib/Test/Simple/Changes b/lib/Test/Simple/Changes index fd9e3f6..2a6ee40 100644 --- a/lib/Test/Simple/Changes +++ b/lib/Test/Simple/Changes @@ -1,5 +1,30 @@ Revision history for Perl extension Test::Simple +0.32 Tue Oct 16 16:52:02 EDT 2001 + * Finally added a seperate plan() function + * Adding a name field to isa_ok() + (Requested by Dave Rolsky) + - Test::More was using Carp.pm, causing the occasional false positive. + (Reported by Tatsuhiko Miyagawa) + +0.31 Mon Oct 8 19:24:53 EDT 2001 + * Added an import option to Test::More + * Added no_ending and no_header options to Test::Builder + (Thanks to Dave Rolsky for giving this a swift kick in the ass) + * Added is_deeply(). Display of scalar refs not quite 100% + (Thanks to Stas Bekman for Apache::TestUtil idea thievery) + - Fixed a minor warning with skip() + (Thanks to Wolfgang Weisselberg for finding this one) + +0.30 Thu Sep 27 22:10:04 EDT 2001 + * Added Test::Builder + * Diagnostics are back to using STDERR *unless* it's from a todo + test. Those go to STDOUT. + - Fixed it so nothing is printed if a test is run with a -c flag. + Handy when a test is being deparsed with B::Deparse. + +0.20 *UNRELEASED* + 0.19 Tue Sep 18 17:48:32 EDT 2001 * Test::Simple and Test::More no longer print their diagnostics to STDERR. It instead goes to STDOUT. diff --git a/lib/Test/Simple/t/Builder.t b/lib/Test/Simple/t/Builder.t new file mode 100644 index 0000000..64dfbea --- /dev/null +++ b/lib/Test/Simple/t/Builder.t @@ -0,0 +1,21 @@ +#!/usr/bin/perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Test::Builder; +my $Test = Test::Builder->new; + +$Test->plan( tests => 4 ); + +my $default_lvl = $Test->level; +$Test->level(0); + +$Test->ok( 1, 'compiled and new()' ); +$Test->ok( $default_lvl == 1, 'level()' ); + +$Test->is_eq('foo', 'foo', 'is_eq'); +$Test->is_num('23.0', '23', 'is_num'); + diff --git a/lib/Test/Simple/t/More.t b/lib/Test/Simple/t/More.t index 7dc6796..ee23f6f 100644 --- a/lib/Test/Simple/t/More.t +++ b/lib/Test/Simple/t/More.t @@ -1,4 +1,11 @@ -use Test::More tests => 22; +#!perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Test::More tests => 24; use_ok('Text::Soundex'); require_ok('Test::More'); @@ -46,6 +53,7 @@ my @complex_array2 = ( [qw(498 10 29)], ); +is_deeply( \@complex_array1, \@complex_array2, 'is_deeply with arrays' ); ok( eq_array(\@complex_array1, \@complex_array2), 'eq_array with complicated arrays' ); ok( eq_set(\@complex_array1, \@complex_array2), @@ -70,9 +78,8 @@ my %hash2 = ( foo => 23, har => { foo => 24, bar => 42 }, ); - -ok( eq_hash(\%hash1, \%hash2), - 'eq_hash with complicated hashes'); +is_deeply( \%hash1, \%hash2, 'is_deeply with complicated hashes' ); +ok( eq_hash(\%hash1, \%hash2), 'eq_hash with complicated hashes'); %hash1 = ( foo => 23, bar => [qw(this that whatever)], diff --git a/lib/Test/Simple/t/exit.t b/lib/Test/Simple/t/exit.t index 855533c..439ccf0 100644 --- a/lib/Test/Simple/t/exit.t +++ b/lib/Test/Simple/t/exit.t @@ -6,7 +6,10 @@ BEGIN { # Can't use Test.pm, that's a 5.005 thing. package My::Test; -use File::Spec; +unless( eval { require File::Spec } ) { + print "1..0 # Skip Need File::Spec to run this test\n"; + exit(0); +} my $test_num = 1; # Utility testing functions. diff --git a/lib/Test/Simple/t/extra.t b/lib/Test/Simple/t/extra.t index e01240a..acb23fd 100644 --- a/lib/Test/Simple/t/extra.t +++ b/lib/Test/Simple/t/extra.t @@ -1,3 +1,5 @@ +#!perl -w + BEGIN { chdir 't' if -d 't'; @INC = '../lib'; @@ -26,7 +28,7 @@ package main; require Test::Simple; -push @INC, '../t/lib'; +push @INC, '../t/lib/'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught(); @@ -49,7 +51,11 @@ ok 4 - Car not ok 5 - Sar OUT - My::Test::ok($$err =~ /Looks like you planned 3 tests but ran 2 extra/); + My::Test::ok($$err eq <import(tests => 1); eval q{ like( "foo", qr/that/, 'is foo like that' ); }; diff --git a/lib/Test/Simple/t/fail-more.t b/lib/Test/Simple/t/fail-more.t index c8b0b59..6c61762 100644 --- a/lib/Test/Simple/t/fail-more.t +++ b/lib/Test/Simple/t/fail-more.t @@ -1,10 +1,17 @@ -use strict; +#!perl -w BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } +use strict; +use lib '../t/lib'; + +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); + + # Can't use Test.pm, that's a 5.005 thing. package My::Test; @@ -29,15 +36,10 @@ sub ok ($;$) { package main; require Test::More; - -push @INC, '../t/lib'; -require Test::Simple::Catch::More; -my($out, $err) = Test::Simple::Catch::More::caught(); - -Test::More->import(tests => 10); +Test::More->import(tests => 12); # Preserve the line numbers. -#line 31 +#line 38 ok( 0, 'failing' ); is( "foo", "bar", 'foo is bar?'); isnt("foo", "foo", 'foo isnt foo?' ); @@ -49,13 +51,15 @@ fail('fail()'); can_ok('Mooble::Hooble::Yooble', qw(this that)); isa_ok(bless([], "Foo"), "Wibble"); +isa_ok(42, "Wibble", "My Wibble"); +isa_ok(undef, "Wibble", "Another Wibble"); use_ok('Hooble::mooble::yooble'); require_ok('ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble'); END { My::Test::ok($$out eq <can(...) -not ok 8 - object->isa('Wibble') -not ok 9 - use Hooble::mooble::yooble; -not ok 10 - require ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble; +not ok 8 - The object isa Wibble +not ok 9 - My Wibble isa Wibble +not ok 10 - Another Wibble isa Wibble +not ok 11 - use Hooble::mooble::yooble; +not ok 12 - require ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble; OUT my $err_re = <can('this') failed # Mooble::Hooble::Yooble->can('that') failed -# Failed test ($0 at line 41) +# Failed test ($0 at line 48) # The object isn't a 'Wibble' +# Failed test ($0 at line 49) +# My Wibble isn't a reference +# Failed test ($0 at line 50) +# Another Wibble isn't defined ERR my $filename = quotemeta $0; my $more_err_re = <import(tests => 5); -#line 32 +#line 35 ok( 1, 'passing' ); ok( 2, 'passing still' ); ok( 3, 'still passing' ); @@ -52,7 +54,11 @@ not ok 4 - oh no! not ok 5 - damnit OUT - My::Test::ok($$err =~ /Looks like you failed 2 tests of 5/); + My::Test::ok($$err eq < 1; + +tie *STDOUT, "Dev::Null" or die $!; + +print "not ok 1\n"; # this should not print. +pass 'STDOUT can be mucked with'; + + +package Dev::Null; + +sub TIEHANDLE { bless {} } +sub PRINT { 1 } diff --git a/lib/Test/Simple/t/import.t b/lib/Test/Simple/t/import.t new file mode 100644 index 0000000..bf0b5a9 --- /dev/null +++ b/lib/Test/Simple/t/import.t @@ -0,0 +1,9 @@ +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Test::More tests => 2, import => [qw(!fail)]; + +can_ok(__PACKAGE__, qw(ok pass like isa_ok)); +ok( !__PACKAGE__->can('fail'), 'fail() not exported' ); diff --git a/lib/Test/Simple/t/is_deeply.t b/lib/Test/Simple/t/is_deeply.t new file mode 100644 index 0000000..ea0c150 --- /dev/null +++ b/lib/Test/Simple/t/is_deeply.t @@ -0,0 +1,211 @@ +#!perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use strict; +use lib qw(../t/lib); + +use Test::Builder; +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); +Test::Builder->new->no_header(1); +Test::Builder->new->no_ending(1); + +# Can't use Test.pm, that's a 5.005 thing. +package main; + +print "1..22\n"; + +my $test_num = 1; +# Utility testing functions. +sub is ($$;$) { + my($this, $that, $name) = @_; + my $test = $$this eq $that; + my $ok = ''; + $ok .= "not " unless $test; + $ok .= "ok $test_num"; + $ok .= " - $name" if defined $name; + $ok .= "\n"; + print $ok; + + unless( $test ) { + print "# got \n$$this"; + print "# expected \n$that"; + } + $test_num++; + + $$this = ''; + + return $test; +} + +sub like ($$;$) { + my($this, $regex, $name) = @_; + + my $test = $$this =~ /$regex/; + + my $ok = ''; + $ok .= "not " unless $test; + $ok .= "ok $test_num"; + $ok .= " - $name" if defined $name; + $ok .= "\n"; + print $ok; + + unless( $test ) { + print "# got \n$$this"; + print "# expected \n$regex"; + } + $test_num++; + + $$this = ''; + + + return $test; +} + + +require Test::More; +Test::More->import(tests => 11, import => ['is_deeply']); + +my $Filename = quotemeta $0; + +#line 68 +is_deeply('foo', 'bar', 'plain strings'); +is( $out, "not ok 1 - plain strings\n", 'plain strings' ); +is( $err, < 42 }, { this => 43 }, 'hashes with different values'); +is( $out, "not ok 3 - hashes with different values\n", + 'hashes with different values' ); +is( $err, <{this} = '42' +# \$expected->{this} = '43' +ERR + +#line 99 +is_deeply({ that => 42 }, { this => 42 }, 'hashes with different keys'); +is( $out, "not ok 4 - hashes with different keys\n", + 'hashes with different keys' ); +is( $err, <{this} = Does not exist +# \$expected->{this} = '42' +ERR + +#line 110 +is_deeply([1..9], [1..10], 'arrays of different length'); +is( $out, "not ok 5 - arrays of different length\n", + 'arrays of different length' ); +is( $err, <[9] = Does not exist +# \$expected->[9] = '10' +ERR + +#line 121 +is_deeply([undef, undef], [undef], 'arrays of undefs' ); +is( $out, "not ok 6 - arrays of undefs\n", 'arrays of undefs' ); +is( $err, <[1] = undef +# \$expected->[1] = Does not exist +ERR + +#line 131 +is_deeply({ foo => undef }, {}, 'hashes of undefs', 'hashes of undefs' ); +is( $out, "not ok 7 - hashes of undefs\n", 'hashes of undefs' ); +is( $err, <{foo} = undef +# \$expected->{foo} = Does not exist +ERR + +#line 141 +is_deeply(\42, \23, 'scalar refs'); +is( $out, "not ok 8 - scalar refs\n", 'scalar refs' ); +is( $err, < \$a3 }; +# $b2 = { foo => \$b3 }; +# is_deeply([$a1], [$b1], 'deep mixed scalar refs'); + +my $foo = { + this => [1..10], + that => { up => "down", left => "right" }, + }; + +my $bar = { + this => [1..10], + that => { up => "down", left => "right", foo => 42 }, + }; + +#line 198 +is_deeply( $foo, $bar, 'deep structures' ); +is( $out, "not ok 11 - deep structures\n", 'deep structures' ); +is( $err, <{that}{foo} = Does not exist +# \$expected->{that}{foo} = '42' +ERR diff --git a/lib/Test/Simple/t/missing.t b/lib/Test/Simple/t/missing.t index 21235a9..9030329 100644 --- a/lib/Test/Simple/t/missing.t +++ b/lib/Test/Simple/t/missing.t @@ -1,10 +1,9 @@ -# Can't use Test.pm, that's a 5.005 thing. - BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } +# Can't use Test.pm, that's a 5.005 thing. package My::Test; print "1..2\n"; @@ -44,7 +43,10 @@ ok 1 - Foo not ok 2 - Bar OUT - My::Test::ok($$err =~ /Looks like you planned 5 tests but only ran 2/); + My::Test::ok($$err eq <new; + $t->no_ending(1); +} + +use Test::More tests => 3; + +# Normally, Test::More would yell that we ran too few tests, but we +# supressed the ending diagnostics. +pass; +print "ok 2\n"; +print "ok 3\n"; diff --git a/lib/Test/Simple/t/no_header.t b/lib/Test/Simple/t/no_header.t new file mode 100644 index 0000000..b0a8d49 --- /dev/null +++ b/lib/Test/Simple/t/no_header.t @@ -0,0 +1,19 @@ +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +# STDOUT must be unbuffered else our prints might come out after +# Test::More's. +$| = 1; + +use Test::Builder; + +BEGIN { + Test::Builder->new->no_header(1); +} + +use Test::More tests => 1; + +print "1..1\n"; +pass; diff --git a/lib/Test/Simple/t/no_plan.t b/lib/Test/Simple/t/no_plan.t index 94d75cb..beca5a6 100644 --- a/lib/Test/Simple/t/no_plan.t +++ b/lib/Test/Simple/t/no_plan.t @@ -1,10 +1,9 @@ -# Can't use Test.pm, that's a 5.005 thing. - BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } +# Can't use Test.pm, that's a 5.005 thing. package My::Test; print "1..12\n"; @@ -53,12 +52,12 @@ eval { My::Test::ok($$out eq ''); My::Test::ok($$err eq ''); -My::Test::ok($@ =~ /You told Test::Simple you plan to run 0 tests!/); +My::Test::ok($@ =~ /You said to run 0 tests!/); eval { Test::Simple::ok(1); }; -My::Test::ok( $@ =~ /You tried to use ok\(\) without a plan!/); +My::Test::ok( $@ =~ /You tried to run a test without a plan!/); END { diff --git a/lib/Test/Simple/t/output.t b/lib/Test/Simple/t/output.t new file mode 100644 index 0000000..ef89a07 --- /dev/null +++ b/lib/Test/Simple/t/output.t @@ -0,0 +1,54 @@ +#!perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +# Can't use Test.pm, that's a 5.005 thing. +print "1..3\n"; + +my $test_num = 1; +# Utility testing functions. +sub ok ($;$) { + my($test, $name) = @_; + my $ok = ''; + $ok .= "not " unless $test; + $ok .= "ok $test_num"; + $ok .= " - $name" if defined $name; + $ok .= "\n"; + print $ok; + $test_num++; +} + +use Test::Builder; +my $Test = Test::Builder->new(); + +my $result; +my $out = $Test->output('foo'); + +ok( defined $out ); + +print $out "hi!\n"; +close *$out; + +undef $out; +open(IN, 'foo') or die $!; +chomp(my $line = ); + +ok($line eq 'hi!'); + +open(FOO, ">>foo") or die $!; +$out = $Test->output(\*FOO); +$old = select *$out; +print "Hello!\n"; +close *$out; +undef $out; +select $old; +open(IN, 'foo') or die $!; +my @lines = ; +close IN; + +ok($lines[1] =~ /Hello!/); + +unlink('foo'); diff --git a/lib/Test/Simple/t/plan.t b/lib/Test/Simple/t/plan.t new file mode 100644 index 0000000..d5d299d --- /dev/null +++ b/lib/Test/Simple/t/plan.t @@ -0,0 +1,11 @@ +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Test::More; + +plan tests => 2; + +pass('Just testing plan()'); +pass('Testing it some more'); diff --git a/lib/Test/Simple/t/plan_is_noplan.t b/lib/Test/Simple/t/plan_is_noplan.t index 98e962a..6d1ed17 100644 --- a/lib/Test/Simple/t/plan_is_noplan.t +++ b/lib/Test/Simple/t/plan_is_noplan.t @@ -1,13 +1,16 @@ +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + # Can't use Test.pm, that's a 5.005 thing. package My::Test; # This feature requires a fairly new version of Test::Harness BEGIN { - chdir 't' if -d 't'; - @INC = '../lib'; require Test::Harness; if( $Test::Harness::VERSION < 1.20 ) { - print "1..0\n"; + print "1..0 # Skipped: Need Test::Harness 1.20 or up\n"; exit(0); } } @@ -33,8 +36,8 @@ package main; require Test::Simple; push @INC, '../t/lib'; -require Test::Simple::Catch::More; -my($out, $err) = Test::Simple::Catch::More::caught(); +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); Test::Simple->import('no_plan'); diff --git a/lib/Test/Simple/t/plan_no_plan.t b/lib/Test/Simple/t/plan_no_plan.t new file mode 100644 index 0000000..0ccc817 --- /dev/null +++ b/lib/Test/Simple/t/plan_no_plan.t @@ -0,0 +1,56 @@ +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +# Can't use Test.pm, that's a 5.005 thing. +package My::Test; + +print "1..2\n"; + +my $test_num = 1; +# Utility testing functions. +sub ok ($;$) { + my($test, $name) = @_; + my $ok = ''; + $ok .= "not " unless $test; + $ok .= "ok $test_num"; + $ok .= " - $name" if defined $name; + $ok .= "\n"; + print $ok; + $test_num++; +} + + +package main; + +require Test::More; +Test::More->import; +my($out, $err); + +BEGIN { + require Test::Harness; +} + +if( $Test::Harness::VERSION < 1.20 ) { + plan(skip_all => 'Need Test::Harness 1.20 or up'); +} +else { + push @INC, '../t/lib'; + require Test::Simple::Catch; + ($out, $err) = Test::Simple::Catch::caught(); + plan('no_plan'); +} + +pass('Just testing'); +ok(1, 'Testing again'); + +END { + My::Test::ok($$out eq < 'Just testing plan & skip_all'; + +fail('We should never get here'); diff --git a/lib/Test/Simple/t/simple.t b/lib/Test/Simple/t/simple.t index 7f4f1f4..de0f9f5 100644 --- a/lib/Test/Simple/t/simple.t +++ b/lib/Test/Simple/t/simple.t @@ -1,3 +1,8 @@ +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + use strict; BEGIN { $| = 1; $^W = 1; } diff --git a/lib/Test/Simple/t/skip.t b/lib/Test/Simple/t/skip.t index 2b46949..fb4daca 100644 --- a/lib/Test/Simple/t/skip.t +++ b/lib/Test/Simple/t/skip.t @@ -1,4 +1,11 @@ -use Test::More tests => 9; +#!perl -w + +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Test::More tests => 15; # If we skip with the same name, Test::Harness will report it back and # we won't get lots of false bug reports. @@ -41,3 +48,37 @@ SKIP: { fail("Deliberate failure"); fail("And again"); } + + +{ + my $warning; + local $SIG{__WARN__} = sub { $warning = join "", @_ }; + SKIP: { + # perl gets the line number a little wrong on the first + # statement inside a block. + 1 == 1; +#line 56 + skip $Why; + fail("So very failed"); + } + is( $warning, "skip() needs to know \$how_many tests are in the ". + "block at $0 line 56\n", + 'skip without $how_many warning' ); +} + + +SKIP: { + skip "Not skipping here.", 4 if 0; + + pass("This is supposed to run"); + + # Testing out nested skips. + SKIP: { + skip $Why, 2; + fail("AHHH!"); + fail("You're a failure"); + } + + pass("This is supposed to run, too"); +} + diff --git a/lib/Test/Simple/t/skipall.t b/lib/Test/Simple/t/skipall.t index 061bfc7..e41dbc7 100644 --- a/lib/Test/Simple/t/skipall.t +++ b/lib/Test/Simple/t/skipall.t @@ -1,10 +1,10 @@ -use strict; - BEGIN { chdir 't' if -d 't'; @INC = '../lib'; } +use strict; + # Can't use Test.pm, that's a 5.005 thing. package My::Test; @@ -28,8 +28,8 @@ package main; require Test::More; push @INC, '../t/lib'; -require Test::Simple::Catch::More; -my($out, $err) = Test::Simple::Catch::More::caught(); +require Test::Simple::Catch; +my($out, $err) = Test::Simple::Catch::caught(); Test::More->import('skip_all'); diff --git a/lib/Test/Simple/t/todo.t b/lib/Test/Simple/t/todo.t index 7cbde95..499229c 100644 --- a/lib/Test/Simple/t/todo.t +++ b/lib/Test/Simple/t/todo.t @@ -1,12 +1,16 @@ -#! /usr/local/bin/perl -w +#!perl -w + BEGIN { chdir 't' if -d 't'; @INC = '../lib'; +} + +BEGIN { require Test::Harness; require Test::More; if( $Test::Harness::VERSION < 1.23 ) { - Test::More->import(skip_all => 'Need the new Test::Harness'); + Test::More->import(skip_all => 'Need Test::Harness 1.23 or up'); } else { Test::More->import(tests => 13); diff --git a/lib/Test/Simple/t/undef.t b/lib/Test/Simple/t/undef.t index 67507a5..97ae307 100644 --- a/lib/Test/Simple/t/undef.t +++ b/lib/Test/Simple/t/undef.t @@ -1,3 +1,8 @@ +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + use strict; use Test::More tests => 10; diff --git a/lib/Test/Simple/t/use_ok.t b/lib/Test/Simple/t/use_ok.t new file mode 100644 index 0000000..e6e306d --- /dev/null +++ b/lib/Test/Simple/t/use_ok.t @@ -0,0 +1,26 @@ +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} + +use Test::More tests => 7; + +# Using Symbol because it's core and exports lots of stuff. +{ + package Foo::one; + ::use_ok("Symbol"); + ::ok( defined &gensym, 'use_ok() no args exports defaults' ); +} + +{ + package Foo::two; + ::use_ok("Symbol", qw(qualify)); + ::ok( !defined &gensym, ' one arg, defaults overriden' ); + ::ok( defined &qualify, ' right function exported' ); +} + +{ + package Foo::three; + ::use_ok("Symbol", qw(gensym ungensym)); + ::ok( defined &gensym && defined &ungensym, ' multiple args' ); +} diff --git a/lib/Test/Simple/t/useing.t b/lib/Test/Simple/t/useing.t index 93ad461..5e5420a 100644 --- a/lib/Test/Simple/t/useing.t +++ b/lib/Test/Simple/t/useing.t @@ -1,5 +1,17 @@ -use Test::More tests => 2; +BEGIN { + chdir 't' if -d 't'; + @INC = '../lib'; +} -use_ok("Test::More"); +use Test::More tests => 5; -use_ok("Test::Simple"); +require_ok('Test::Builder'); +require_ok("Test::More"); +require_ok("Test::Simple"); + +{ + package Foo; + use Test::More import => [qw(ok is can_ok)]; + can_ok('Foo', qw(ok is can_ok)); + ok( !Foo->can('like'), 'import working properly' ); +} diff --git a/lib/Test/Utils.pm b/lib/Test/Utils.pm deleted file mode 100644 index 1d00f90..0000000 --- a/lib/Test/Utils.pm +++ /dev/null @@ -1,28 +0,0 @@ -package Test::Utils; - -use 5.004; - -use strict; -require Exporter; -use vars qw($VERSION @EXPORT @EXPORT_TAGS @ISA); - -$VERSION = '0.02'; - -@ISA = qw(Exporter); -@EXPORT = qw( my_print print ); - - - -# Special print function to guard against $\ and -l munging. -sub my_print (*@) { - my($fh, @args) = @_; - - return 1 if $^C; - - local $\; - print $fh @args; -} - -sub print { die "DON'T USE PRINT! Use _print instead" } - -1; diff --git a/t/lib/Test/Simple/Catch.pm b/t/lib/Test/Simple/Catch.pm index 3460a64..e1ccd7c 100644 --- a/t/lib/Test/Simple/Catch.pm +++ b/t/lib/Test/Simple/Catch.pm @@ -1,16 +1,18 @@ # For testing Test::Simple; package Test::Simple::Catch; -my $out = tie *Test::Simple::TESTOUT, __PACKAGE__; -my $err = tie *Test::Simple::TESTERR, __PACKAGE__; +use Symbol; +my($out_fh, $err_fh) = (gensym, gensym); +my $out = tie *$out_fh, __PACKAGE__; +my $err = tie *$err_fh, __PACKAGE__; -# We have to use them to shut up a "used only once" warning. -() = (*Test::Simple::TESTOUT, *Test::Simple::TESTERR); +use Test::Builder; +my $t = Test::Builder->new; +$t->output($out_fh); +$t->failure_output($err_fh); +$t->todo_output($err_fh); -sub caught { return $out, $err } - -# Prevent Test::Simple from exiting in its END block. -*Test::Simple::exit = sub {}; +sub caught { return($out, $err) } sub PRINT { my $self = shift; @@ -25,5 +27,6 @@ sub TIEHANDLE { sub READ {} sub READLINE {} sub GETC {} +sub FILENO {} 1; diff --git a/t/lib/Test/Simple/Catch/More.pm b/t/lib/Test/Simple/Catch/More.pm deleted file mode 100644 index f4dee3f..0000000 --- a/t/lib/Test/Simple/Catch/More.pm +++ /dev/null @@ -1,30 +0,0 @@ -# For testing Test::More; -package Test::Simple::Catch::More; - -my $out = tie *Test::Simple::TESTOUT, __PACKAGE__; -tie *Test::More::TESTOUT, __PACKAGE__, $out; -my $err = tie *Test::More::TESTERR, __PACKAGE__; -tie *Test::Simple::TESTERR, __PACKAGE__, $err; - -# We have to use them to shut up a "used only once" warning. -() = (*Test::More::TESTOUT, *Test::More::TESTERR); - -sub caught { return $out, $err } - - -sub PRINT { - my $self = shift; - $$self .= join '', @_; -} - -sub TIEHANDLE { - my($class, $self) = @_; - my $foo = ''; - $self = $self || \$foo; - return bless $self, $class; -} -sub READ {} -sub READLINE {} -sub GETC {} - -1; diff --git a/t/lib/Test/Simple/sample_tests/five_fail.plx b/t/lib/Test/Simple/sample_tests/five_fail.plx index d33b845..c058e1f 100644 --- a/t/lib/Test/Simple/sample_tests/five_fail.plx +++ b/t/lib/Test/Simple/sample_tests/five_fail.plx @@ -1,6 +1,6 @@ require Test::Simple; -push @INC, 't/lib'; +use lib 't/lib'; require Test::Simple::Catch; my($out, $err) = Test::Simple::Catch::caught();