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/Changes Test::More changes
-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/More.t Test::More test, basic operation
-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/Changes Test::Simple changes
+lib/Test/Simple/t/More.t Test::More test, basic stuff
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/missing.t Test::Simple test, missing tests
lib/Test/Simple/t/no_plan.t Test::Simple test, forgot the plan
lib/Test/Simple/t/plan_is_noplan.t Test::Simple test, no_plan
-lib/Test/Simple/t/simple.t for exit.t
+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/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
lib/Test/t/onfail.t See if Test works
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/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
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/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
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" }
+use 5.004;
+use strict;
+use Carp;
+use Test::Utils;
BEGIN {
require Test::Simple;
require Exporter;
use vars qw($VERSION @ISA @EXPORT);
-$VERSION = '0.07';
+$VERSION = '0.18';
@ISA = qw(Exporter);
@EXPORT = qw(ok use_ok require_ok
is isnt like
skip todo
pass fail
eq_array eq_hash eq_set
+ skip
+ $TODO
+ plan
+ can_ok isa_ok
);
sub import {
my($class, $plan, @args) = @_;
- if( $plan eq 'skip_all' ) {
- $Test::Simple::Skip_All = 1;
- _print *TESTOUT, "1..0\n";
- exit(0);
+ 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($plan => @args);
+ Test::Simple->import;
}
__PACKAGE__->_export_to_level(1, __PACKAGE__);
# or
use Test::More qw(no_plan);
# or
- use Test::More qw(skip_all);
+ use Test::More skip_all => $reason;
BEGIN { use_ok( 'Some::Module' ); }
require_ok( 'Some::Module' );
isnt($this, $that, $test_name);
like($this, qr/that/, $test_name);
- skip { # UNIMPLEMENTED!!!
+ SKIP: {
+ skip $why, $how_many unless $have_some_feature;
+
ok( foo(), $test_name );
is( foo(42), 23, $test_name );
- } $how_many, $why;
+ };
+
+ TODO: {
+ local $TODO = $why;
- todo { # UNIMPLEMENTED!!!
ok( foo(), $test_name );
is( foo(42), 23, $test_name );
- } $how_many, $why;
+ };
+
+ can_ok($module, @methods);
+ isa_ok($object, $class);
pass($test_name);
fail($test_name);
# UNIMPLEMENTED!!!
my @status = Test::More::status;
+ # UNIMPLEMENTED!!!
+ BAIL_OUT($why);
+
=head1 DESCRIPTION
If you're just getting started writing tests, have a look at
-Test::Simple first.
+Test::Simple first. This is a drop in replacement for Test::Simple
+which you can switch to once you get the hang of basic testing.
This module provides a very wide range of testing utilities. Various
ways to say "ok", facilities to skip tests, test future features
In some cases, you'll want to completely skip an entire testing script.
- use Test::More qw(skip_all);
+ use Test::More skip_all => $skip_reason;
-Your script will declare a skip and exit immediately with a zero
-(success). L<Test::Harness> for details.
+Your script will declare a skip with the reason why you skipped and
+exit immediately with a zero (success). See L<Test::Harness> for
+details.
=head2 Test names
is ( $this, $that, $test_name );
isnt( $this, $that, $test_name );
-Similar to ok(), is() and isnt() compare their two arguments with
-C<eq> and C<ne> respectively and use the result of that to determine
-if the test succeeded or failed. So these:
+Similar to ok(), is() and isnt() compare their two arguments
+with C<eq> and C<ne> 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" );
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:
+test:
my $foo = 'waffle'; my $bar = 'yarblokos';
is( $foo, $bar, 'Is foo the same as bar?' );
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().
+For those grammatical pedants out there, there's an C<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);
+ 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 ) {
- _print *TESTERR, <<DIAGNOSTIC;
-# got: '$this'
-# expected: '$that'
+ $this = defined $this ? "'$this'" : 'undef';
+ $that = defined $that ? "'$that'" : 'undef';
+ my_print *TESTERR, sprintf <<DIAGNOSTIC, $this, $that;
+# got: %s
+# expected: %s
DIAGNOSTIC
}
sub isnt ($$;$) {
my($this, $that, $name) = @_;
- my $ok = @_ == 3 ? ok($this ne $that, $name)
- : ok($this ne $that);
+ my $test;
+ {
+ local $^W = 0; # so isnt(undef, undef) works quietly.
+ $test = $this ne $that;
+ }
+
+ my $ok = @_ == 3 ? ok($test, $name)
+ : ok($test);
unless( $ok ) {
- _print *TESTERR, <<DIAGNOSTIC;
-# it should not be '$that'
+ $that = defined $that ? "'$that'" : 'undef';
+
+ my_print *TESTERR, sprintf <<DIAGNOSTIC, $that;
+# it should not be %s
# but it is.
DIAGNOSTIC
(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
+regex reference (ie. C<qr//>) or (for better compatibility with older
perls) as a string that looks like a regex (alternative delimiters are
currently not supported):
my $ok = 0;
if( ref $regex eq 'Regexp' ) {
+ local $^W = 0;
$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 ) {
+ local $^W = 0;
$ok = @_ == 3 ? ok( $this =~ /(?$opts)$re/ ? 1 : 0, $name )
: ok( $this =~ /(?$opts)$re/ ? 1 : 0 );
}
my $ok = @_ == 3 ? ok(0, $name )
: ok(0);
- _print *TESTERR, <<ERR;
+ my_print *TESTERR, <<ERR;
# '$regex' doesn't look much like a regex to me. Failing the test.
ERR
}
unless( $ok ) {
- _print *TESTERR, <<DIAGNOSTIC;
-# '$this'
+ $this = defined $this ? "'$this'" : 'undef';
+ my_print *TESTERR, sprintf <<DIAGNOSTIC, $this;
+# %s
# doesn't match '$regex'
DIAGNOSTIC
return $ok;
}
+=item B<can_ok>
+
+ can_ok($module, @methods);
+ can_ok($object, @methods);
+
+Checks to make sure the $module or $object can do these @methods
+(works with functions, too).
+
+ can_ok('Foo', qw(this that whatever));
+
+is almost exactly like saying:
+
+ ok( Foo->can('this') &&
+ Foo->can('that') &&
+ Foo->can('whatever')
+ );
+
+only without all the typing and with a better interface. Handy for
+quickly testing an interface.
+
+=cut
+
+sub can_ok ($@) {
+ my($proto, @methods) = @_;
+ my $class= ref $proto || $proto;
+
+ my @nok = ();
+ foreach my $method (@methods) {
+ my $test = "$class->can('$method')";
+ eval $test || push @nok, $method;
+ }
+
+ my $name;
+ $name = @methods == 1 ? "$class->can($methods[0])"
+ : "$class->can(...)";
+
+ ok( !@nok, $name );
+
+ my_print *TESTERR, map "# $class->can('$_') failed\n", @nok;
+
+ return !@nok;
+}
+
+=item B<isa_ok>
+
+ isa_ok($object, $class);
+
+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
+of thing:
+
+ my $obj = Some::Module->new;
+ isa_ok( $obj, 'Some::Module' );
+
+where you'd otherwise have to write
+
+ my $obj = Some::Module->new;
+ ok( defined $obj && $obj->isa('Some::Module') );
+
+to safeguard against your test script blowing up.
+
+=cut
+
+sub isa_ok ($$) {
+ my($object, $class) = @_;
+
+ my $diag;
+ my $name = "object->isa('$class')";
+ if( !defined $object ) {
+ $diag = "The object isn't defined";
+ }
+ elsif( !ref $object ) {
+ $diag = "The object isn't a reference";
+ }
+ elsif( !$object->isa($class) ) {
+ $diag = "The object isn't a '$class'";
+ }
+
+ if( $diag ) {
+ ok( 0, $name );
+ my_print *TESTERR, "# $diag\n";
+ return 0;
+ }
+ else {
+ ok( 1, $name );
+ return 1;
+ }
+}
+
+
=item B<pass>
=item B<fail>
=cut
-sub pass ($) {
+sub pass (;$) {
my($name) = @_;
return @_ == 1 ? ok(1, $name)
: ok(1);
}
-sub fail ($) {
+sub fail (;$) {
my($name) = @_;
return @_ == 1 ? ok(0, $name)
: ok(0);
=item B<use_ok>
-=item B<require_ok>
-
BEGIN { use_ok($module); }
- require_ok($module);
+ BEGIN { use_ok($module, @imports); }
+
+These simply use 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.
+
+If @imports are given, they are passed through to the use. So this:
+
+ BEGIN { use_ok('Some::Module', qw(foo bar)) }
+
+is like doing this:
+
+ use Some::Module qw(foo bar);
-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;
+sub use_ok ($;@) {
+ my($module, @imports) = @_;
+ @imports = () unless @imports;
my $pack = caller;
eval <<USE;
package $pack;
require $module;
-$module->import;
+$module->import(\@imports);
USE
my $ok = ok( !$@, "use $module;" );
unless( $ok ) {
- _print *TESTERR, <<DIAGNOSTIC;
+ my_print *TESTERR, <<DIAGNOSTIC;
# Tried to use '$module'.
# Error: $@
DIAGNOSTIC
return $ok;
}
+=item B<require_ok>
+
+ require_ok($module);
+
+Like use_ok(), except it requires the $module.
+
+=cut
sub require_ok ($) {
my($module) = shift;
my $ok = ok( !$@, "require $module;" );
unless( $ok ) {
- _print *TESTERR, <<DIAGNOSTIC;
+ my_print *TESTERR, <<DIAGNOSTIC;
# Tried to require '$module'.
# Error: $@
DIAGNOSTIC
return $ok;
}
+=back
=head2 Conditional tests
+B<WARNING!> The following describes an I<experimental> interface that
+is subject to change B<WITHOUT NOTICE>! Use at your peril.
+
Sometimes running a test under certain conditions will cause the
test script to die. A certain function or method isn't implemented
(such as fork() on MacOS), some resource isn't available (like a
-net connection) or a module isn't available. In these cases its
-necessary to skip test, or declare that they are supposed to fail
+net connection) or a module isn't available. In these cases it's
+necessary to skip tests, or declare that they are supposed to fail
but will work in the future (a todo test).
-For more details on skip and todo tests, L<Test::Harness>.
+For more details on skip and todo tests see L<Test::Harness>.
+
+The way Test::More handles this is with a named block. Basically, a
+block of tests which can be skipped over or made todo. It's best if I
+just show you...
=over 4
-=item B<skip> * UNIMPLEMENTED *
+=item B<SKIP: BLOCK>
+
+ SKIP: {
+ skip $why, $how_many if $condition;
- skip BLOCK $how_many, $why, $if;
+ ...normal testing code goes here...
+ }
-B<NOTE> Should that be $if or $unless?
+This declares a block of tests to skip, $how_many tests there are,
+$why and under what $condition to skip them. An example is the
+easiest way to illustrate:
-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: {
+ skip "Pigs don't fly here", 2 unless Pigs->can('fly');
- 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 };
+ my $pig = Pigs->new;
+ $pig->takeoff;
+
+ ok( $pig->altitude > 0, 'Pig is airborne' );
+ ok( $pig->airspeed > 0, ' and moving' );
+ }
-The $if condition is optional, but $why is not.
+If pigs cannot fly, the whole block of tests will be skipped
+completely. Test::More will output special ok's which Test::Harness
+interprets as skipped tests. Its important to include $how_many tests
+are in the block so the total number of tests comes out right (unless
+you're using C<no_plan>).
+
+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
+feature (like fork() or symlinks) or maybe you need an Internet
+connection and one isn't available.
+
+=for _Future
+See L</Why are skip and todo so weird?>
=cut
+#'#
sub skip {
- die "skip() is UNIMPLEMENTED!";
+ my($why, $how_many) = @_;
+ unless( $how_many >= 1 ) {
+ # $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;
+ $how_many = 1;
+ }
+
+ for( 1..$how_many ) {
+ Test::Simple::_skipped($why);
+ }
+
+ local $^W = 0;
+ last SKIP;
}
-=item B<todo> * UNIMPLEMENTED *
- todo BLOCK $how_many, $why;
- todo BLOCK $how_many, $why, $until;
+=item B<TODO: BLOCK>
-Declares a block of tests you expect to fail and why. Perhaps its
-because you haven't fixed a bug:
+ TODO: {
+ local $TODO = $why;
- todo { is( $Gravitational_Constant, 0 ) } 1,
- "Still tinkering with physics --God";
+ ...normal testing code goes here...
+ }
-If you have a set of functionality yet to implement, you can make the
-whole suite dependent on that new feature.
+Declares a block of tests you expect to fail and $why. Perhaps it's
+because you haven't fixed a bug or haven't finished a 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');
+ TODO: {
+ local $TODO = "URI::Geller not finished";
-=cut
+ my $card = "Eight of clubs";
+ is( URI::Geller->your_card, $card, 'Is THIS your card?' );
-sub todo {
- die "todo() is UNIMPLEMENTED!";
-}
+ my $spoon;
+ URI::Geller->bend_spoon;
+ is( $spoon, 'bent', "Spoon bending, that's original" );
+ }
+
+With a todo block, the tests inside are expected to fail. Test::More
+will run the tests normally, but print out special flags indicating
+they are "todo". Test::Harness will interpret failures as being ok.
+Should anything succeed, it will report it as an unexpected success.
+
+The nice part about todo tests, as opposed to simply commenting out a
+block of tests, is it's like having a programatic todo list. You know
+how much work is left to be done, you're aware of what bugs there are,
+and you'll know immediately when they're fixed.
+
+Once a todo test starts succeeding, simply move it outside the block.
+When the block is empty, delete it.
+
+
+=back
=head2 Comparision functions
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);
+ my $eq;
+ {
+ # Quiet unintialized value warnings when comparing undefs.
+ local $^W = 0;
+
+ if( $e1 eq $e2 ) {
+ $ok = 1;
}
else {
- $ok = 0;
+ 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;
}
# 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 _bogus_sort { local $^W = 0; ref $a ? 0 : $a cmp $b }
sub eq_set {
my($a1, $a2) = @_;
=back
+=head1 NOTES
+
+Test::More is B<explicitly> tested all the way back to perl 5.004.
+
=head1 BUGS and CAVEATS
-The eq_* family have some caveats.
+=over 4
+
+=item Making your own ok()
+
+This will not do what you mean:
+
+ sub my_ok {
+ ok( @_ );
+ }
+
+ my_ok( 2 + 2 == 5, 'Basic addition' );
+
+since ok() takes it's arguments as scalars, it will see the length of
+@_ (2) and always pass the test. You want to do this instead:
-todo() and skip() are unimplemented.
+ sub my_ok {
+ ok( $_[0], $_[1] );
+ }
+
+The other functions act similiarly.
+
+=item The eq_* family have some caveats.
+
+=item Test::Harness upgrades
-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.
+no_plan and todo depend on new Test::Harness features and fixes. 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.
+
+If you simply depend on Test::More, it's own dependencies will cause a
+Test::Harness upgrade.
+
+=back
=head1 AUTHOR
-Michael G Schwern <schwern@pobox.com> with much inspiration from
+Michael G Schwern E<lt>schwern@pobox.comE<gt> 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
+module. I was largely unware of its existence 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).
+++ /dev/null
-Revision history for Perl extension Test::More.
-
-0.07 Wed Jun 27 03:06:56 EDT 2001
- - VMS and Win32 fixes. Nothing was actually wrong, but the tests
- had little problems.
- - like()'s failure report wasn't always accurate
-
-0.06 Fri Jun 15 14:39:50 EDT 2001
- - Guarding against $/ and -l
- - Reformatted the way failed tests are reported to make them stand out
- a bit better.
- - Fixed tests without names
-
-0.05 Tue Jun 12 16:16:55 EDT 2001
- * use Test::More no_plan; implemented
-
-0.04 Thu Jun 7 11:26:18 BST 2001
- - minor bug in eq_set() with complex data structures
- Thanks to Tatsuhiko Miyagawa for finding this.
-
-0.03 Tue Jun 5 19:59:59 BST 2001
- - Fixed export problem in 5.004.
- - prototyped the functions properly
- * fixed bug with like() involving qr//
-
-0.02 Thu Apr 5 12:48:48 BST 2001
- - Fixed Makefile.PL to work around MakeMaker bug that 'use's Test::Simple
- instead of 'require'ing.
-
-0.01 Fri Mar 30 07:49:14 GMT 2001
- - First working version
-
+++ /dev/null
-# 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;
-
-@INC = ('../lib', 'lib/Test/More');
-require Catch;
-my($out, $err) = Catch::caught();
-
-
-Test::More->import('no_plan');
-
-ok(1, 'foo');
-
-
-END {
- My::Test::ok($$out eq <<OUT);
-ok 1 - foo
-1..1
-OUT
-
- My::Test::ok($$err eq <<ERR);
-ERR
-
- # Prevent Test::More from exiting with non zero
- exit 0;
-}
package Test::Simple;
-require 5.004;
+use 5.004;
-$Test::Simple::VERSION = '0.09';
+use strict 'vars';
+use Test::Utils;
+
+use vars qw($VERSION);
+
+$VERSION = '0.18';
my(@Test_Results) = ();
my($Num_Tests, $Planned_Tests, $Test_Died) = (0,0,0);
my($Have_Plan) = 0;
-
-# 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" }
+my $IsVMS = $^O eq 'VMS';
# I'd like to have Test::Simple interfere with the program being
$Have_Plan = 1;
- _print *TESTOUT, "1..$Planned_Tests\n";
+ my_print *TESTOUT, "1..$Planned_Tests\n";
+ no strict 'refs';
my($caller) = caller;
*{$caller.'::ok'} = \&ok;
-
+
}
$Have_Plan = 1;
my($caller) = caller;
+ no strict 'refs';
*{$caller.'::ok'} = \&ok;
}
=head1 DESCRIPTION
+** If you are unfamiliar with testing B<read Test::Tutorial> first! **
+
This is an extremely simple, extremely basic module for writing tests
-suitable for CPAN modules and other pursuits.
+suitable for CPAN modules and other pursuits. If you wish to do more
+complicated testing, use the Test::More module (a drop-in replacement
+for this one).
The basic unit of Perl testing is the ok. For each thing you want to
test your program will print out an "ok" or "not ok" to indicate pass
ok( @stuff, 'I have some stuff' );
-will do what you mean (fail if stuff is empty).
+will do what you mean (fail if stuff is empty)
=cut
$Num_Tests++;
- # Make sure the print doesn't get interfered with.
- local($\, $,);
-
- _print *TESTERR, <<ERR if defined $name and $name !~ /\D/;
+ my_print *TESTERR, <<ERR if defined $name and $name !~ /\D/;
You named your test '$name'. You shouldn't use numbers for your test names.
Very confusing.
ERR
+ my($pack, $file, $line) = caller;
+ if( $pack eq 'Test::More' ) { # special case for Test::More's calls
+ ($pack, $file, $line) = caller(1);
+ }
+
+ my($is_todo) = ${$pack.'::TODO'} ? 1 : 0;
+
# We must print this all in one shot or else it will break on VMS
my $msg;
unless( $test ) {
$msg .= "not ";
- $Test_Results[$Num_Tests-1] = 0;
+ $Test_Results[$Num_Tests-1] = $is_todo ? 1 : 0;
}
else {
$Test_Results[$Num_Tests-1] = 1;
}
$msg .= "ok $Num_Tests";
- $msg .= " - $name" if @_ == 2;
+
+ if( @_ == 2 ) {
+ $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
+ $msg .= " - $name";
+ }
+ if( $is_todo ) {
+ my $what_todo = ${$pack.'::TODO'};
+ $msg .= " # TODO $what_todo";
+ }
$msg .= "\n";
- _print *TESTOUT, $msg;
+ my_print *TESTOUT, $msg;
#'#
- unless( $test ) {
- my($pack, $file, $line) = (caller)[0,1,2];
- if( $pack eq 'Test::More' ) {
- ($file, $line) = (caller(1))[1,2];
- }
- _print *TESTERR, "# Failed test ($file at line $line)\n";
+ unless( $test or $is_todo ) {
+ my_print *TESTERR, "# Failed test ($file at line $line)\n";
}
- return $test;
+ return $test ? 1 : 0;
}
+
+sub _skipped {
+ my($why) = shift;
+
+ 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++;
+
+ # 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;
+}
+
+
=back
Test::Simple will start by printing number of tests run in the form
=cut
sub _my_exit {
- $? = $_[0];
- return 1;
+ $? = $_[0];
+
+ return 1;
}
if( $Num_Tests ) {
# The plan? We have no plan.
unless( $Planned_Tests ) {
- _print *TESTOUT, "1..$Num_Tests\n";
+ my_print *TESTOUT, "1..$Num_Tests\n";
$Planned_Tests = $Num_Tests;
}
$num_failed += abs($Planned_Tests - @Test_Results);
if( $Num_Tests < $Planned_Tests ) {
- _print *TESTERR, <<"FAIL";
+ 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;
- _print *TESTERR, <<"FAIL";
+ my_print *TESTERR, <<"FAIL";
# Looks like you planned $Planned_Tests tests but ran $num_extra extra.
FAIL
}
elsif ( $num_failed ) {
- _print *TESTERR, <<"FAIL";
+ my_print *TESTERR, <<"FAIL";
# Looks like you failed $num_failed tests of $Planned_Tests.
FAIL
}
if( $Test_Died ) {
- _print *TESTERR, <<"FAIL";
+ my_print *TESTERR, <<"FAIL";
# Looks like your test died just after $Num_Tests.
FAIL
_my_exit( 0 ) && return;
}
else {
- _print *TESTERR, "# No tests run!\n";
+ my_print *TESTERR, "# No tests run!\n";
_my_exit( 255 ) && return;
}
}
ok( defined($btaste) and ref $btaste eq 'Film', 'new() works' );
ok( $btaste->Title eq 'Bad Taste', 'Title() get' );
- ok( $btsate->Director eq 'Peter Jackson', 'Director() get' );
+ ok( $btaste->Director eq 'Peter Jackson', 'Director() get' );
ok( $btaste->Rating eq 'R', 'Rating() get' );
ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' );
ok 2 - Title() get
ok 3 - Director() get
not ok 4 - Rating() get
+ # Failed test (t/film.t at line 14)
ok 5 - NumExplodingSheep() get
+ # Looks like you failed 1 tests of 5
Indicating the Film::Rating() method is broken.
Split it into multiple files. (Otherwise blame the Unix folks for
using an unsigned short integer as the exit status).
+Because VMS's exit codes are much, much different than the rest of the
+universe, and perl does horrible mangling to them that gets in my way,
+it works like this on VMS.
+
+ 0 SS$_NORMAL all tests successful
+ 4 SS$_ABORT something went wrong
+
+Unfortunately, I can't differentiate any further.
+
+
+=head1 NOTES
+
+Test::Simple is B<explicitly> tested all the way back to perl 5.004.
+
=head1 HISTORY
=head1 AUTHOR
Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
-<schwern@pobox.com>, wardrobe by Calvin Klein.
+E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
=head1 SEE ALSO
Revision history for Perl extension Test::Simple
+0.18 Wed Sep 5 20:35:24 EDT 2001
+ * ***API CHANGE*** can_ok() only counts as one test
+ - can_ok() has better diagnostics
+ - Minor POD fixes from mjd
+ - adjusting the internal layout to make it easier to put it into
+ the core
+
+0.17 Wed Aug 29 20:16:28 EDT 2001
+ * Added can_ok() and isa_ok() to Test::More
+
+0.16 Tue Aug 28 19:52:11 EDT 2001
+ * vmsperl foiled my sensisble exit codes. Reverting to a much more
+ coarse scheme.
+
+0.15 Tue Aug 28 06:18:35 EDT 2001 *UNRELEASED*
+ * Now using sensible exit codes on VMS.
+
+0.14 Wed Aug 22 17:26:28 EDT 2001
+ * Added a first cut at Test::Tutorial
+
+0.13 Tue Aug 14 15:30:10 EDT 2001
+ * Added a reason to the skip_all interface
+ - Fixed a bug to allow 'use Test::More;' to work.
+ (Thanks to Tatsuhiko Miyagawa again)
+ - Now always testing backwards compatibility.
+
+0.12 Tue Aug 14 11:02:39 EDT 2001
+ * Fixed some compatibility bugs with older Perls
+ (Thanks to Tatsuhiko Miyagawa)
+
+0.11 Sat Aug 11 23:05:19 EDT 2001
+ * Will no longer warn about testing undef values
+ - Escaping # in test names
+ - Ensuring that ok() returns true or false and not undef
+ - Minor doc typo in the example
+
+0.10 Tue Jul 31 15:01:11 EDT 2001
+ * Test::More is now distributed in this tarball.
+ * skip and todo tests work!
+ * Extended use_ok() so it can import
+ - A little internal rejiggering
+ - Added a TODO file
+
0.09 Wed Jun 27 02:55:54 EDT 2001
- VMS fixes
-use Test::More tests => 18;
+use Test::More tests => 22;
use_ok('Text::Soundex');
require_ok('Test::More');
#'#
like("fooble", '/^foo/', 'foo is like fooble');
like("FooBle", '/foo/i', 'foo is like FooBle');
+like("/usr/local/pr0n/", '/^\/usr\/local/', 'regexes with slashes in like' );
+
+can_ok('Test::More', qw(require_ok use_ok ok is isnt like skip can_ok
+ pass fail eq_array eq_hash eq_set));
+can_ok(bless({}, "Test::More"), qw(require_ok use_ok ok is isnt like skip
+ can_ok pass fail eq_array eq_hash eq_set));
+
+isa_ok(bless([], "Foo"), "Foo");
+
pass('pass() passed');
package main;
+my $IsVMS = $^O eq 'VMS';
+
+print "# Ahh! I see you're running VMS.\n" if $IsVMS;
+
my %Tests = (
- 'success.plx' => 0,
- 'one_fail.plx' => 1,
- 'two_fail.plx' => 2,
- 'five_fail.plx' => 5,
- 'extras.plx' => 3,
- 'too_few.plx' => 4,
- 'death.plx' => 255,
- 'last_minute_death.plx' => 255,
- 'death_in_eval.plx' => 0,
- 'require.plx' => 0,
+ # Everyone Else VMS
+ 'success.plx' => [0, 0],
+ 'one_fail.plx' => [1, 4],
+ 'two_fail.plx' => [2, 4],
+ 'five_fail.plx' => [5, 4],
+ 'extras.plx' => [3, 4],
+ 'too_few.plx' => [4, 4],
+ 'death.plx' => [255, 4],
+ 'last_minute_death.plx' => [255, 4],
+ 'death_in_eval.plx' => [0, 0],
+ 'require.plx' => [0, 0],
);
print "1..".keys(%Tests)."\n";
-chdir 't' if -d 't';
-use File::Spec;
-my $lib = File::Spec->catdir('lib', 'Test', 'Simple', 'sample_tests');
-while( my($test_name, $exit_code) = each %Tests ) {
- my $file = File::Spec->catfile($lib, $test_name);
- my $wait_stat = system(qq{$^X -"I../lib" -"Ilib/Test/Simple" $file});
- My::Test::ok( $wait_stat >> 8 == $exit_code,
- "$test_name exited with $exit_code" );
-}
+while( my($test_name, $exit_codes) = each %Tests ) {
+ my($exit_code) = $exit_codes->[$IsVMS ? 1 : 0];
+ my $wait_stat = system(qq{$^X t/lib/Test/Simple/sample_tests/$test_name});
+ my $actual_exit = $wait_stat >> 8;
+ My::Test::ok( $actual_exit == $exit_code,
+ "$test_name exited with $actual_exit (expected $exit_code)");
+}
require Test::Simple;
-@INC = ('../lib', 'lib/Test/Simple');
-require Catch;
-my($out, $err) = Catch::caught();
+push @INC, 't/lib/';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
Test::Simple->import(tests => 3);
package main;
+
require Test::More;
-@INC = ('../lib', 'lib/Test/More');
-require Catch;
-my($out, $err) = Catch::caught();
+push @INC, 't/lib';
+require Test::Simple::Catch::More;
+my($out, $err) = Test::Simple::Catch::More::caught();
Test::More->import(tests => 1);
$ok .= "\n";
print $ok;
$test_num++;
+
+ return $test;
}
package main;
+
require Test::More;
-@INC = ('../lib', 'lib/Test/More');
-require Catch;
-my($out, $err) = Catch::caught();
+push @INC, 't/lib';
+require Test::Simple::Catch::More;
+my($out, $err) = Test::Simple::Catch::More::caught();
-Test::More->import(tests => 8);
+Test::More->import(tests => 10);
+# Preserve the line numbers.
+#line 31
ok( 0, 'failing' );
is( "foo", "bar", 'foo is bar?');
isnt("foo", "foo", 'foo isnt foo?' );
fail('fail()');
+can_ok('Mooble::Hooble::Yooble', qw(this that));
+isa_ok(bless([], "Foo"), "Wibble");
+
use_ok('Hooble::mooble::yooble');
require_ok('ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble');
END {
My::Test::ok($$out eq <<OUT, 'failing output');
-1..8
+1..10
not ok 1 - failing
not ok 2 - foo is bar?
not ok 3 - foo isnt foo?
not ok 4 - foo isn't foo?
not ok 5 - is foo like that
not ok 6 - fail()
-not ok 7 - use Hooble::mooble::yooble;
-not ok 8 - require ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble;
+not ok 7 - Mooble::Hooble::Yooble->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;
OUT
my $err_re = <<ERR;
# 'foo'
# doesn't match '/that/'
# Failed test ($0 at line 38)
+# Failed test ($0 at line 40)
+# Mooble::Hooble::Yooble->can('this') failed
+# Mooble::Hooble::Yooble->can('that') failed
+# Failed test ($0 at line 41)
+# The object isn't a 'Wibble'
ERR
my $filename = quotemeta $0;
my $more_err_re = <<ERR;
-# Failed test \\($filename at line 40\\)
+# Failed test \\($filename at line 43\\)
# Tried to use 'Hooble::mooble::yooble'.
# Error: Can't locate Hooble.* in \\\@INC .*
-# Failed test \\($filename at line 41\\)
+# Failed test \\($filename at line 44\\)
# Tried to require 'ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble'.
# Error: Can't locate ALL.* in \\\@INC .*
-# Looks like you failed 8 tests of 8.
+# Looks like you failed 10 tests of 10.
ERR
- My::Test::ok($$err =~ /^\Q$err_re\E$more_err_re$/, 'failing errors');
+ unless( My::Test::ok($$err =~ /^\Q$err_re\E$more_err_re$/,
+ 'failing errors') ) {
+ print map "# $_", $$err;
+ }
exit(0);
}
require Test::Simple;
-@INC = ('../lib', 'lib/Test/Simple');
-require Catch;
-my($out, $err) = Catch::caught();
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
Test::Simple->import(tests => 5);
require Test::Simple;
-@INC = ('../lib', 'lib/Test/Simple');
-require Catch;
-my($out, $err) = Catch::caught();
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
Test::Simple->import(tests => 5);
require Test::Simple;
-@INC = ('../lib', 'lib/Test/Simple');
-require Catch;
-my($out, $err) = Catch::caught();
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
eval {
Test::Simple->import;
require Test::Simple;
-@INC = ('../lib', 'lib/Test/Simple');
-require Catch;
-my($out, $err) = Catch::caught();
+push @INC, 't/lib';
+require Test::Simple::Catch::More;
+my($out, $err) = Test::Simple::Catch::More::caught();
Test::Simple->import('no_plan');
+++ /dev/null
-use strict;
-
-BEGIN { $| = 1; $^W = 1; }
-
-use Test::Simple tests => 3;
-
-ok(1, 'compile');
-
-ok(1);
-ok(1, 'foo');
--- /dev/null
+use Test::More tests => 9;
+
+# If we skip with the same name, Test::Harness will report it back and
+# we won't get lots of false bug reports.
+my $Why = "Just testing the skip interface.";
+
+SKIP: {
+ skip $Why, 2
+ unless Pigs->can('fly');
+
+ my $pig = Pigs->new;
+ $pig->takeoff;
+
+ ok( $pig->altitude > 0, 'Pig is airborne' );
+ ok( $pig->airspeed > 0, ' and moving' );
+}
+
+
+SKIP: {
+ skip "We're not skipping", 2 if 0;
+
+ pass("Inside skip block");
+ pass("Another inside");
+}
+
+
+SKIP: {
+ skip "Again, not skipping", 2 if 0;
+
+ my($pack, $file, $line) = caller;
+ is( $pack || '', '', 'calling package not interfered with' );
+ is( $file || '', '', ' or file' );
+ is( $line || '', '', ' or line' );
+}
+
+
+SKIP: {
+ skip $Why, 2 if 1;
+
+ die "A horrible death";
+ fail("Deliberate failure");
+ fail("And again");
+}
package main;
require Test::More;
-@INC = ('../lib', 'lib/Test/More');
-require Catch;
-my($out, $err) = Catch::caught();
+push @INC, 't/lib';
+require Test::Simple::Catch::More;
+my($out, $err) = Test::Simple::Catch::More::caught();
Test::More->import('skip_all');
--- /dev/null
+BEGIN {
+ require Test::Harness;
+ require Test::More;
+
+ if( $Test::Harness::VERSION < 1.23 ) {
+ Test::More->import(skip_all => 'Need the new Test::Harness');
+ }
+ else {
+ Test::More->import(tests => 5);
+ }
+}
+
+$Why = 'Just testing the todo interface.';
+
+TODO: {
+ local $TODO = $Why;
+
+ fail("Expected failure");
+ fail("Another expected failure");
+}
+
+
+pass("This is not todo");
+
+
+TODO: {
+ local $TODO = $Why;
+
+ fail("Yet another failure");
+}
+
+pass("This is still not todo");
--- /dev/null
+use strict;
+use Test::More tests => 10;
+
+BEGIN { $^W = 1; }
+
+my $warnings = '';
+local $SIG{__WARN__} = sub { $warnings = join '', @_ };
+
+is( undef, undef, 'undef is undef');
+is( $warnings, '', ' no warnings' );
+
+isnt( undef, 'foo', 'undef isnt foo');
+is( $warnings, '', ' no warnings' );
+
+like( undef, '/.*/', 'undef is like anything' );
+is( $warnings, '', ' no warnings' );
+
+eq_array( [undef, undef], [undef, 23] );
+is( $warnings, '', 'eq_array() no warnings' );
+
+eq_hash ( { foo => undef, bar => undef },
+ { foo => undef, bar => 23 } );
+is( $warnings, '', 'eq_hash() no warnings' );
+
+eq_set ( [undef, undef, 12], [29, undef, undef] );
+is( $warnings, '', 'eq_set() no warnings' );
+
+
+eq_hash ( { foo => undef, bar => { baz => undef, moo => 23 } },
+ { foo => undef, bar => { baz => undef, moo => 23 } } );
+is( $warnings, '', 'eq_hash() no warnings' );
+
+
--- /dev/null
+use Test::More tests => 2;
+
+use_ok("Test::More");
+
+use_ok("Test::Simple");
--- /dev/null
+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) = @_;
+
+ local $\;
+ print $fh @args;
+}
+
+sub print { die "DON'T USE PRINT! Use _print instead" }
+
+1;
# For testing Test::Simple;
-package Catch;
+package Test::Simple::Catch;
-my $out = tie *Test::Simple::TESTOUT, 'Catch';
-my $err = tie *Test::Simple::TESTERR, 'Catch';
+my $out = tie *Test::Simple::TESTOUT, __PACKAGE__;
+my $err = tie *Test::Simple::TESTERR, __PACKAGE__;
# We have to use them to shut up a "used only once" warning.
() = (*Test::Simple::TESTOUT, *Test::Simple::TESTERR);
# For testing Test::More;
-package Catch;
+package Test::Simple::Catch::More;
-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;
+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);
require Test::Simple;
-push @INC, 't', '.';
-require Catch;
-my($out, $err) = Catch::caught();
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
Test::Simple->import(tests => 5);
close STDERR;
require Test::Simple;
use Carp;
-push @INC, 't', '.';
-require Catch;
-my($out, $err) = Catch::caught();
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
Test::Simple->import(tests => 5);
require Test::Simple;
-push @INC, 't', '.';
-require Catch;
-my($out, $err) = Catch::caught();
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
Test::Simple->import(tests => 5);
require Test::Simple;
-push @INC, 't', '.';
-require Catch;
-my($out, $err) = Catch::caught();
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
Test::Simple->import(tests => 5);
require Test::Simple;
-push @INC, 't', '.';
-require Catch;
-my($out, $err) = Catch::caught();
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
Test::Simple->import(tests => 5);
close STDERR;
require Test::Simple;
-push @INC, 't', '.';
-require Catch;
-my($out, $err) = Catch::caught();
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
Test::Simple->import(tests => 5);
require Test::Simple;
-push @INC, 't', '.';
-require Catch;
-my($out, $err) = Catch::caught();
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
Test::Simple->import(tests => 5);
require Test::Simple;
-push @INC, 't', '.';
-require Catch;
-my($out, $err) = Catch::caught();
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
Test::Simple->import(tests => 5);
require Test::Simple;
-push @INC, 't', '.';
-require Catch;
-my($out, $err) = Catch::caught();
+push @INC, 't/lib';
+require Test::Simple::Catch;
+my($out, $err) = Test::Simple::Catch::caught();
Test::Simple->import(tests => 5);
projects / p5sagit/p5-mst-13.2.git / commitdiff