From: Jarkko Hietaniemi Date: Mon, 25 Jun 2001 13:38:08 +0000 (+0000) Subject: Add Test::More, from Michael G Schwern. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3f2ec160bb5d4b0fa4d71d9d6810ad59d6a54b71;p=p5sagit%2Fp5-mst-13.2.git Add Test::More, from Michael G Schwern. p4raw-id: //depot/perl@10914 --- diff --git a/MANIFEST b/MANIFEST index 72d226c..96ab2d3 100644 --- a/MANIFEST +++ b/MANIFEST @@ -1090,6 +1090,12 @@ lib/termcap.pl Perl library supporting termcap usage lib/Test.pm A simple framework for writing test scripts lib/Test/Harness.pm A test harness lib/Test/Harness.t See if Test::Harness works +lib/Test/More.pm More utilities for writing tests +lib/Test/More/t/More.t Test::More test, basic operation +lib/Test/More/t/fail-like.t Test::More test, like() and qr// bug +lib/Test/More/t/fail.t Test::More test, failing tests +lib/Test/More/t/plan_is_noplan.t Test::More test, noplan +lib/Test/More/t/skipall.t Test::More test, skipping all tests lib/Test/Simple.pm Basic utility for writing tests lib/Test/Simple/t/exit.t Test::Simple test, exit codes lib/Test/Simple/t/extra.t Test::Simple test @@ -1852,6 +1858,7 @@ t/lib/st-dump.pl See if Storable works 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/More/Catch.pm Utility module for testing Test::More t/lib/Test/Simple/Catch.pm Utility module for testing Test::Simple t/lib/Test/Simple/sample_tests/death.plx for exit.t t/lib/Test/Simple/sample_tests/death_in_eval.plx for exit.t diff --git a/lib/Test/More.pm b/lib/Test/More.pm new file mode 100644 index 0000000..da35d26 --- /dev/null +++ b/lib/Test/More.pm @@ -0,0 +1,702 @@ +package Test::More; + +use strict; + + +# Special print function to guard against $\ and -l munging. +sub _print (*@) { + my($fh, @args) = @_; + + local $\; + print $fh @args; +} + +sub print { die "DON'T USE PRINT! Use _print instead" } + + +BEGIN { + require Test::Simple; + *TESTOUT = \*Test::Simple::TESTOUT; + *TESTERR = \*Test::Simple::TESTERR; +} + +require Exporter; +use vars qw($VERSION @ISA @EXPORT); +$VERSION = '0.06'; +@ISA = qw(Exporter); +@EXPORT = qw(ok use_ok require_ok + is isnt like + skip todo + pass fail + eq_array eq_hash eq_set + ); + + +sub import { + my($class, $plan, @args) = @_; + + if( $plan eq 'skip_all' ) { + $Test::Simple::Skip_All = 1; + _print *TESTOUT, "1..0\n"; + exit(0); + } + else { + Test::Simple->import($plan => @args); + } + + __PACKAGE__->_export_to_level(1, __PACKAGE__); +} + +# 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, @_); +} + + +=head1 NAME + +Test::More - yet another framework for writing test scripts + +=head1 SYNOPSIS + + use Test::More tests => $Num_Tests; + # or + use Test::More qw(no_plan); + # or + use Test::More qw(skip_all); + + BEGIN { use_ok( 'Some::Module' ); } + require_ok( 'Some::Module' ); + + # Various ways to say "ok" + ok($this eq $that, $test_name); + + is ($this, $that, $test_name); + isnt($this, $that, $test_name); + like($this, qr/that/, $test_name); + + skip { # UNIMPLEMENTED!!! + ok( foo(), $test_name ); + is( foo(42), 23, $test_name ); + } $how_many, $why; + + todo { # UNIMPLEMENTED!!! + ok( foo(), $test_name ); + is( foo(42), 23, $test_name ); + } $how_many, $why; + + pass($test_name); + fail($test_name); + + # Utility comparison functions. + eq_array(\@this, \@that); + eq_hash(\%this, \%that); + eq_set(\@this, \@that); + + # UNIMPLEMENTED!!! + my @status = Test::More::status; + + +=head1 DESCRIPTION + +If you're just getting started writing tests, have a look at +Test::Simple first. + +This module provides a very wide range of testing utilities. Various +ways to say "ok", facilities to skip tests, test future features +and compare complicated data structures. + + +=head2 I love it when a plan comes together + +Before anything else, you need a testing plan. This basically declares +how many tests your script is going to run to protect against premature +failure. + +The prefered way to do this is to declare a plan when you C. + + use Test::More tests => $Num_Tests; + +There are rare cases when you will not know beforehand how many tests +your script is going to run. In this case, you can declare that you +have no plan. (Try to avoid using this as it weakens your test.) + + use Test::More qw(no_plan); + +In some cases, you'll want to completely skip an entire testing script. + + use Test::More qw(skip_all); + +Your script will declare a skip and exit immediately with a zero +(success). L for details. + + +=head2 Test names + +By convention, each test is assigned a number in order. This is +largely done automatically for you. However, its often very useful to +assign a name to each test. Which would you rather see: + + ok 4 + not ok 5 + ok 6 + +or + + ok 4 - basic multi-variable + not ok 5 - simple exponential + ok 6 - force == mass * acceleration + +The later gives you some idea of what failed. It also makes it easier +to find the test in your script, simply search for "simple +exponential". + +All test functions take a name argument. Its optional, but highly +suggested that you use it. + + +=head2 I'm ok, you're not ok. + +The basic purpose of this module is to print out either "ok #" or "not +ok #" depending on if a given test succeeded or failed. Everything +else is just gravy. + +All of the following print "ok" or "not ok" depending on if the test +succeeded or failed. They all also return true or false, +respectively. + +=over 4 + +=item B + + ok($this eq $that, $test_name); + +This simply evaluates any expression (C<$this eq $that> is just a +simple example) and uses that to determine if the test succeeded or +failed. A true expression passes, a false one fails. Very simple. + +For example: + + ok( $exp{9} == 81, 'simple exponential' ); + ok( Film->can('db_Main'), 'set_db()' ); + ok( $p->tests == 4, 'saw tests' ); + ok( !grep !defined $_, @items, 'items populated' ); + +(Mnemonic: "This is ok.") + +$test_name is a very short description of the test that will be printed +out. It makes it very easy to find a test in your script when it fails +and gives others an idea of your intentions. $test_name is optional, +but we B strongly encourage its use. + +Should an ok() fail, it will produce some diagnostics: + + not ok 18 - sufficient mucus + # Failed test 18 (foo.t at line 42) + +This is actually Test::Simple's ok() routine. + +=cut + +# We get ok() from Test::Simple's import(). + +=item B + +=item B + + is ( $this, $that, $test_name ); + isnt( $this, $that, $test_name ); + +Similar to ok(), is() and isnt() compare their two arguments with +C and C respectively and use the result of that to determine +if the test succeeded or failed. So these: + + # Is the ultimate answer 42? + is( ultimate_answer(), 42, "Meaning of Life" ); + + # $foo isn't empty + isnt( $foo, '', "Got some foo" ); + +are similar to these: + + ok( ultimate_answer() eq 42, "Meaning of Life" ); + ok( $foo ne '', "Got some foo" ); + +(Mnemonic: "This is that." "This isn't that.") + +So why use these? They produce better diagnostics on failure. ok() +cannot know what you are testing for (beyond the name), but is() and +isnt() know what the test was and why it failed. For example this + test: + + my $foo = 'waffle'; my $bar = 'yarblokos'; + is( $foo, $bar, 'Is foo the same as bar?' ); + +Will produce something like this: + + not ok 17 - Is foo the same as bar? + # Failed test 1 (foo.t at line 139) + # got: 'waffle' + # expected: 'yarblokos' + +So you can figure out what went wrong without rerunning the test. + +You are encouraged to use is() and isnt() over ok() where possible, +however do not be tempted to use them to find out if something is +true or false! + + # XXX BAD! $pope->isa('Catholic') eq 1 + is( $pope->isa('Catholic'), 1, 'Is the Pope Catholic?' ); + +This does not check if C<$pope->isa('Catholic')> is true, it checks if +it returns 1. Very different. Similar caveats exist for false and 0. +In these cases, use ok(). + + ok( $pope->isa('Catholic') ), 'Is the Pope Catholic?' ); + +For those grammatical pedants out there, there's an isn't() function +which is an alias of isnt(). + +=cut + +sub is ($$;$) { + my($this, $that, $name) = @_; + + my $ok = @_ == 3 ? ok($this eq $that, $name) + : ok($this eq $that); + + unless( $ok ) { + _print *TESTERR, < + + like( $this, qr/that/, $test_name ); + +Similar to ok(), like() matches $this against the regex C. + +So this: + + like($this, qr/that/, 'this is like that'); + +is similar to: + + ok( $this =~ /that/, 'this is like that'); + +(Mnemonic "This is like that".) + +The second argument is a regular expression. It may be given as a +regex reference (ie. qr//) or (for better compatibility with older +perls) as a string that looks like a regex (alternative delimiters are +currently not supported): + + like( $this, '/that/', 'this is like that' ); + +Regex options may be placed on the end (C<'/that/i'>). + +Its advantages over ok() are similar to that of is() and isnt(). Better +diagnostics on failure. + +=cut + +sub like ($$;$) { + my($this, $regex, $name) = @_; + + my $ok = 0; + if( ref $regex eq 'Regexp' ) { + $ok = @_ == 3 ? ok( $this =~ $regex ? 1 : 0, $name ) + : ok( $this =~ $regex ? 1 : 0 ); + } + # Check if it looks like '/foo/i' + elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) { + $ok = @_ == 3 ? ok( $this =~ /(?$opts)$re/ ? 1 : 0, $name ) + : ok( $this =~ /(?$opts)$re/ ? 1 : 0 ); + } + else { + # Can't use fail() here, the call stack will be fucked. + my $ok = @_ == 3 ? ok(0, $name ) + : ok(0); + + _print *TESTERR, < + +=item B + + pass($test_name); + fail($test_name); + +Sometimes you just want to say that the tests have passed. Usually +the case is you've got some complicated condition that is difficult to +wedge into an ok(). In this case, you can simply use pass() (to +declare the test ok) or fail (for not ok). They are synonyms for +ok(1) and ok(0). + +Use these very, very, very sparingly. + +=cut + +sub pass ($) { + my($name) = @_; + return @_ == 1 ? ok(1, $name) + : ok(1); +} + +sub fail ($) { + my($name) = @_; + return @_ == 1 ? ok(0, $name) + : ok(0); +} + +=back + +=head2 Module tests + +You usually want to test if the module you're testing loads ok, rather +than just vomiting if its load fails. For such purposes we have +C and C. + +=over 4 + +=item B + +=item B + + BEGIN { use_ok($module); } + require_ok($module); + +These simply use or require the given $module and test to make sure +the load happened ok. Its recommended that you run use_ok() inside a +BEGIN block so its functions are exported at compile-time and +prototypes are properly honored. + +=cut + +sub use_ok ($) { + my($module) = shift; + + my $pack = caller; + + eval <import; +USE + + my $ok = ok( !$@, "use $module;" ); + + unless( $ok ) { + _print *TESTERR, <. + +=over 4 + +=item B * UNIMPLEMENTED * + + skip BLOCK $how_many, $why, $if; + +B Should that be $if or $unless? + +This declares a block of tests to skip, why and under what conditions +to skip them. An example is the easiest way to illustrate: + + skip { + ok( head("http://www.foo.com"), "www.foo.com is alive" ); + ok( head("http://www.foo.com/bar"), " and has bar" ); + } 2, "LWP::Simple not installed", + !eval { require LWP::Simple; LWP::Simple->import; 1 }; + +The $if condition is optional, but $why is not. + +=cut + +sub skip (&$$;$) { + my($tests, $how_many, $why, $if) = @_; + + if( $if ) { + + } +} + +=item B * UNIMPLEMENTED * + + todo BLOCK $how_many, $why; + todo BLOCK $how_many, $why, $until; + +Declares a block of tests you expect to fail and why. Perhaps its +because you haven't fixed a bug: + + todo { is( $Gravitational_Constant, 0 ) } 1, + "Still tinkering with physics --God"; + +If you have a set of functionality yet to implement, you can make the +whole suite dependent on that new feature. + + todo { + $pig->takeoff; + ok( $pig->altitude > 0 ); + ok( $pig->mach > 2 ); + ok( $pig->serve_peanuts ); + } 1, "Pigs are still safely grounded", + Pigs->can('fly'); + +=cut + +sub todo (&$$;$) { + my($tests, $how_many, $name, $if) = @_; +} + +=head2 Comparision functions + +Not everything is a simple eq check or regex. There are times you +need to see if two arrays are equivalent, for instance. For these +instances, Test::More provides a handful of useful functions. + +B These are NOT well-tested on circular references. Nor am I +quite sure what will happen with filehandles. + +=over 4 + +=item B + + eq_array(\@this, \@that); + +Checks if two arrays are equivalent. This is a deep check, so +multi-level structures are handled correctly. + +=cut + +#'# +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->[$_]); + $ok = _deep_check($e1,$e2); + last unless $ok; + } + return $ok; +} + +sub _deep_check { + my($e1, $e2) = @_; + my $ok = 0; + + if($e1 eq $e2) { + $ok = 1; + } + else { + if( UNIVERSAL::isa($e1, 'ARRAY') and + UNIVERSAL::isa($e2, 'ARRAY') ) + { + $ok = eq_array($e1, $e2); + } + elsif( UNIVERSAL::isa($e1, 'HASH') and + UNIVERSAL::isa($e2, 'HASH') ) + { + $ok = eq_hash($e1, $e2); + } + else { + $ok = 0; + } + } + return $ok; +} + + +=item B + + eq_hash(\%this, \%that); + +Determines if the two hashes contain the same keys and values. This +is a deep check. + +=cut + +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}); + $ok = _deep_check($e1, $e2); + last unless $ok; + } + + return $ok; +} + +=item B + + eq_set(\@this, \@that); + +Similar to eq_array(), except the order of the elements is B +important. This is a deep check, but the irrelevancy of order only +applies to the top level. + +=cut + +# We must make sure that references are treated neutrally. It really +# doesn't matter how we sort them, as long as both arrays are sorted +# with the same algorithm. +sub _bogus_sort { ref $a ? 0 : $a cmp $b } + +sub eq_set { + my($a1, $a2) = @_; + return 0 unless @$a1 == @$a2; + + # There's faster ways to do this, but this is easiest. + return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] ); +} + + +=back + +=head1 BUGS and CAVEATS + +The eq_* family have some caveats. + +todo() and skip() are unimplemented. + +The no_plan feature depends on new Test::Harness feature. If you're going +to distribute tests that use no_plan your end-users will have to upgrade +Test::Harness to the latest one on CPAN. + +=head1 AUTHOR + +Michael G Schwern with much inspiration from +Joshua Pritikin's Test module and lots of discussion with Barrie +Slaymaker and the perl-qa gang. + + +=head1 HISTORY + +This is a case of convergent evolution with Joshua Pritikin's Test +module. I was actually largely unware of its existance when I'd first +written my own ok() routines. This module exists because I can't +figure out how to easily wedge test names into Test's interface (along +with a few other problems). + +The goal here is to have a testing utility that's simple to learn, +quick to use and difficult to trip yourself up with while still +providing more flexibility than the existing Test.pm. As such, the +names of the most common routines are kept tiny, special cases and +magic side-effects are kept to a minimum. WYSIWYG. + + +=head1 SEE ALSO + +L if all this confuses you and you just want to write +some tests. You can upgrade to Test::More later (its forward +compatible). + +L for a similar testing module. + +L for details on how your test results are interpreted +by Perl. + +L describes a very featureful unit testing interface. + +L shows the idea of embedded testing. + +L is another approach to embedded testing. + +=cut + +1; diff --git a/lib/Test/More/t/More.t b/lib/Test/More/t/More.t new file mode 100644 index 0000000..74e64c8 --- /dev/null +++ b/lib/Test/More/t/More.t @@ -0,0 +1,78 @@ +use Test::More tests => 18; + +use_ok('Text::Soundex'); +require_ok('Test::More'); + + +ok( 2 eq 2, 'two is two is two is two' ); +is( "foo", "foo", 'foo is foo' ); +isnt( "foo", "bar", 'foo isnt bar'); +isn't("foo", "bar", 'foo isn\'t bar'); + +#'# +like("fooble", '/^foo/', 'foo is like fooble'); +like("FooBle", '/foo/i', 'foo is like FooBle'); + +pass('pass() passed'); + +ok( eq_array([qw(this that whatever)], [qw(this that whatever)]), + 'eq_array with simple arrays' ); +ok( eq_hash({ foo => 42, bar => 23 }, {bar => 23, foo => 42}), + 'eq_hash with simple hashes' ); +ok( eq_set([qw(this that whatever)], [qw(that whatever this)]), + 'eq_set with simple sets' ); + +my @complex_array1 = ( + [qw(this that whatever)], + {foo => 23, bar => 42}, + "moo", + "yarrow", + [qw(498 10 29)], + ); +my @complex_array2 = ( + [qw(this that whatever)], + {foo => 23, bar => 42}, + "moo", + "yarrow", + [qw(498 10 29)], + ); + +ok( eq_array(\@complex_array1, \@complex_array2), + 'eq_array with complicated arrays' ); +ok( eq_set(\@complex_array1, \@complex_array2), + 'eq_set with complicated arrays' ); + +my @array1 = (qw(this that whatever), + {foo => 23, bar => 42} ); +my @array2 = (qw(this that whatever), + {foo => 24, bar => 42} ); + +ok( !eq_array(\@array1, \@array2), + 'eq_array with slightly different complicated arrays' ); +ok( !eq_set(\@array1, \@array2), + 'eq_set with slightly different complicated arrays' ); + +my %hash1 = ( foo => 23, + bar => [qw(this that whatever)], + har => { foo => 24, bar => 42 }, + ); +my %hash2 = ( foo => 23, + bar => [qw(this that whatever)], + har => { foo => 24, bar => 42 }, + ); + + +ok( eq_hash(\%hash1, \%hash2), + 'eq_hash with complicated hashes'); + +%hash1 = ( foo => 23, + bar => [qw(this that whatever)], + har => { foo => 24, bar => 42 }, + ); +%hash2 = ( foo => 23, + bar => [qw(this tha whatever)], + har => { foo => 24, bar => 42 }, + ); + +ok( !eq_hash(\%hash1, \%hash2), + 'eq_hash with slightly different complicated hashes' ); diff --git a/lib/Test/More/t/fail-like.t b/lib/Test/More/t/fail-like.t new file mode 100644 index 0000000..69d8574 --- /dev/null +++ b/lib/Test/More/t/fail-like.t @@ -0,0 +1,62 @@ +# qr// was introduced in 5.004-devel. Skip this test if we're not +# of high enough version. +BEGIN { + if( $] < 5.005 ) { + print "1..0\n"; + exit(0); + } +} + + +# There was a bug with like() involving a qr// not failing properly. +# This tests against that. + +use strict; + +# 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) = @_; + print "not " unless $test; + print "ok $test_num"; + print " - $name" if defined $name; + print "\n"; + $test_num++; +} + + +package main; +require Test::More; + +push @INC, 'lib/Test/More/'; +require Catch; +my($out, $err) = Catch::caught(); + +Test::More->import(tests => 1); + +eval q{ like( "foo", qr/that/, 'is foo like that' ); }; + + +END { + My::Test::ok($$out eq <import(tests => 8); + +ok( 0, 'failing' ); +is( "foo", "bar", 'foo is bar?'); +isnt("foo", "foo", 'foo isnt foo?' ); +isn't("foo", "foo",'foo isn\'t foo?' ); + +like( "foo", '/that/', 'is foo like that' ); + +fail('fail()'); + +use_ok('Hooble::mooble::yooble'); +require_ok('ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble'); + +END { + My::Test::ok($$out eq <import('no_plan'); + +ok(1, 'foo'); + + +END { + My::Test::ok($$out eq <import('skip_all'); + + +END { + My::Test::ok($$out eq "1..0\n"); + My::Test::ok($$err eq ""); +} diff --git a/t/lib/Test/More/Catch.pm b/t/lib/Test/More/Catch.pm new file mode 100644 index 0000000..aed9468 --- /dev/null +++ b/t/lib/Test/More/Catch.pm @@ -0,0 +1,30 @@ +# For testing Test::More; +package Catch; + +my $out = tie *Test::Simple::TESTOUT, 'Catch'; +tie *Test::More::TESTOUT, 'Catch', $out; +my $err = tie *Test::More::TESTERR, 'Catch'; +tie *Test::Simple::TESTERR, 'Catch', $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;