lib/Test/Simple/Changes Test::Simple changes
lib/Test/Simple/README Test::Simple README
lib/Test/Simple/t/Builder.t Test::Builder tests
+lib/Test/Simple/t/buffer.t Test::Builder buffering test
+lib/Test/Simple/t/diag.t Test::More diag() test
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
use strict;
use vars qw($VERSION $CLASS);
-$VERSION = 0.05;
+$VERSION = '0.11';
$CLASS = __PACKAGE__;
my $IsVMS = $^O eq 'VMS';
=head1 DESCRIPTION
-I<THIS IS ALPHA GRADE SOFTWARE> The interface will change.
+I<THIS IS ALPHA GRADE SOFTWARE> Meaning the underlying code is well
+tested, yet the interface is subject to 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.
+but they're not always flexible enough. Test::Builder provides the a
+building block upon which to write your own test libraries I<which can
+work together>.
=head2 Construction
$Curr_Test++;
$self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
-You named your test '$name'. You shouldn't use numbers for your test names.
-Very confusing.
+ You named your test '$name'. You shouldn't use numbers for your test names.
+ Very confusing.
ERR
my($pack, $file, $line) = $self->caller;
unless( $test ) {
my $msg = $todo ? "Failed (TODO)" : "Failed";
- $self->diag("$msg test ($file at line $line)\n");
+ $self->diag(" $msg test ($file at line $line)\n");
}
return $test ? 1 : 0;
=item B<is_num>
- $Test->is_num($get, $expected, $name);
+ $Test->is_num($got, $expected, $name);
Like Test::More's is(). Checks if $got == $expected. This is the
numeric version.
=cut
sub is_eq {
- my $self = shift;
+ my($self, $got, $expect, $name) = @_;
local $Level = $Level + 1;
- return $self->_is('eq', @_);
+
+ if( !defined $got || !defined $expect ) {
+ # undef only matches undef and nothing else
+ my $test = !defined $got && !defined $expect;
+
+ $self->ok($test, $name);
+ $self->_is_diag($got, 'eq', $expect) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok($got, 'eq', $expect, $name);
}
sub is_num {
- my $self = shift;
+ my($self, $got, $expect, $name) = @_;
local $Level = $Level + 1;
- return $self->_is('==', @_);
+
+ if( !defined $got || !defined $expect ) {
+ # undef only matches undef and nothing else
+ my $test = !defined $got && !defined $expect;
+
+ $self->ok($test, $name);
+ $self->_is_diag($got, '==', $expect) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok($got, '==', $expect, $name);
}
-sub _is {
- my($self, $type, $got, $expect, $name) = @_;
+sub _is_diag {
+ my($self, $got, $type, $expect) = @_;
+
+ foreach my $val (\$got, \$expect) {
+ if( defined $$val ) {
+ if( $type eq 'eq' ) {
+ # quote and force string context
+ $$val = "'$$val'"
+ }
+ else {
+ # force numeric context
+ $$val = $$val+0;
+ }
+ }
+ else {
+ $$val = 'undef';
+ }
+ }
- my $test;
- {
- local $^W = 0; # so we can compare undef quietly
- $test = $type eq 'eq' ? $got eq $expect
- : $got == $expect;
+ $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
+ got: %s
+ expected: %s
+DIAGNOSTIC
+
+}
+
+=item B<isnt_eq>
+
+ $Test->isnt_eq($got, $dont_expect, $name);
+
+Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
+the string version.
+
+=item B<isnt_num>
+
+ $Test->is_num($got, $dont_expect, $name);
+
+Like Test::More's isnt(). Checks if $got ne $dont_expect. This is
+the numeric version.
+
+=cut
+
+sub isnt_eq {
+ my($self, $got, $dont_expect, $name) = @_;
+ local $Level = $Level + 1;
+
+ if( !defined $got || !defined $dont_expect ) {
+ # undef only matches undef and nothing else
+ my $test = defined $got || defined $dont_expect;
+
+ $self->ok($test, $name);
+ $self->_cmp_diag('ne', $got, $dont_expect) unless $test;
+ return $test;
}
+
+ return $self->cmp_ok($got, 'ne', $dont_expect, $name);
+}
+
+sub isnt_num {
+ my($self, $got, $dont_expect, $name) = @_;
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 <<DIAGNOSTIC, $got, $expect);
- got: %s
-expected: %s
-DIAGNOSTIC
- }
+ if( !defined $got || !defined $dont_expect ) {
+ # undef only matches undef and nothing else
+ my $test = defined $got || defined $dont_expect;
- return $ok;
+ $self->ok($test, $name);
+ $self->_cmp_diag('!=', $got, $dont_expect) unless $test;
+ return $test;
+ }
+
+ return $self->cmp_ok($got, '!=', $dont_expect, $name);
}
+
=item B<like>
$Test->like($this, qr/$regex/, $name);
You'll want to avoid qr// if you want your tests to work before 5.005.
+=item B<unlike>
+
+ $Test->unlike($this, qr/$regex/, $name);
+ $Test->unlike($this, '/$regex/', $name);
+
+Like Test::More's unlike(). Checks if $this B<does not match> the
+given $regex.
+
=cut
sub like {
my($self, $this, $regex, $name) = @_;
local $Level = $Level + 1;
+ $self->_regex_ok($this, $regex, '=~', $name);
+}
+
+sub unlike {
+ my($self, $this, $regex, $name) = @_;
+
+ local $Level = $Level + 1;
+ $self->_regex_ok($this, $regex, '!~', $name);
+}
+
+sub _regex_ok {
+ my($self, $this, $regex, $cmp, $name) = @_;
+
+ local $Level = $Level + 1;
my $ok = 0;
+ my $usable_regex;
if( ref $regex eq 'Regexp' ) {
- local $^W = 0;
- $ok = $self->ok( $this =~ $regex ? 1 : 0, $name );
+ $usable_regex = $regex;
}
# 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 );
+ $usable_regex = "(?$opts)$re";
}
else {
$ok = $self->ok( 0, $name );
- $self->diag("'$regex' doesn't look much like a regex to me.");
+ $self->diag(" '$regex' doesn't look much like a regex to me.");
return $ok;
}
+ {
+ local $^W = 0;
+ my $test = $this =~ /$usable_regex/ ? 1 : 0;
+ $test = !$test if $cmp eq '!~';
+ $ok = $self->ok( $test, $name );
+ }
+
unless( $ok ) {
$this = defined $this ? "'$this'" : 'undef';
- $self->diag(sprintf <<DIAGNOSTIC, $this);
- %s
-doesn't match '$regex'
+ my $match = $cmp eq '=~' ? "doesn't match" : "matches";
+ $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
+ %s
+ %13s '%s'
DIAGNOSTIC
}
return $ok;
}
+=item B<cmp_ok>
+
+ $Test->cmp_ok($this, $type, $that, $name);
+
+Works just like Test::More's cmp_ok().
+
+ $Test->cmp_ok($big_num, '!=', $other_big_num);
+
+=cut
+
+sub cmp_ok {
+ my($self, $got, $type, $expect, $name) = @_;
+
+ my $test;
+ {
+ local $^W = 0;
+ local($@,$!); # don't interfere with $@
+ # eval() sometimes resets $!
+ $test = eval "\$got $type \$expect";
+ }
+ local $Level = $Level + 1;
+ my $ok = $self->ok($test, $name);
+
+ unless( $ok ) {
+ if( $type =~ /^(eq|==)$/ ) {
+ $self->_is_diag($got, $type, $expect);
+ }
+ else {
+ $self->_cmp_diag($got, $type, $expect);
+ }
+ }
+ return $ok;
+}
+
+sub _cmp_diag {
+ my($self, $got, $type, $expect) = @_;
+
+ $got = defined $got ? "'$got'" : 'undef';
+ $expect = defined $expect ? "'$expect'" : 'undef';
+ $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
+ %s
+ %s
+ %s
+DIAGNOSTIC
+}
+
+=item B<BAILOUT>
+
+ $Test->BAILOUT($reason);
+
+Indicates to the Test::Harness that things are going so badly all
+testing should terminate. This includes running any additional test
+scripts.
+
+It will exit with 255.
+
+=cut
+
+sub BAILOUT {
+ my($self, $reason) = @_;
+
+ $self->_print("Bail out! $reason");
+ exit 255;
+}
+
=item B<skip>
$Test->skip;
return 1;
}
+
+=item B<todo_skip>
+
+ $Test->todo_skip;
+ $Test->todo_skip($why);
+
+Like skip(), only it will declare the test as failing and TODO. Similar
+to
+
+ print "not ok $tnum # TODO $why\n";
+
+=cut
+
+sub todo_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 = "not ok";
+ $out .= " $Curr_Test" if $self->use_numbers;
+ $out .= " # TODO $why\n";
+
+ $Test->_print($out);
+
+ return 1;
+}
+
+
=begin _unimplemented
=item B<skip_rest>
used.
Output will be indented and marked with a # so as not to interfere
-with test output.
+with test output. A newline will be put on the end if there isn't one
+already.
We encourage using this rather than calling print directly.
sub diag {
my($self, @msgs) = @_;
+ return unless @msgs;
# Prevent printing headers when compiling (i.e. -c)
return if $^C;
# Escape each line with a #.
foreach (@msgs) {
- s/^([^#])/# $1/;
- s/\n([^#])/\n# $1/g;
+ s/^/# /gms;
}
+ push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
+
local $Level = $Level + 1;
my $fh = $self->todo ? $self->todo_output : $self->failure_output;
local($\, $", $,) = (undef, ' ', '');
# 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: $!";
+
+ # Set everything to unbuffered else plain prints to STDOUT will
+ # come out in the wrong order from our own prints.
_autoflush(\*TESTOUT);
+ _autoflush(\*STDOUT);
_autoflush(\*TESTERR);
+ _autoflush(\*STDERR);
+
$CLASS->output(\*TESTOUT);
$CLASS->failure_output(\*TESTERR);
$CLASS->todo_output(\*TESTOUT);
if( $Curr_Test < $Expected_Tests ) {
$self->diag(<<"FAIL");
-# Looks like you planned $Expected_Tests tests but only ran $Curr_Test.
+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.
+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.
+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.
+Looks like your test died just after $Curr_Test.
FAIL
_my_exit( 255 ) && return;
_my_exit( 0 ) && return;
}
else {
- $self->diag("# No tests run!\n");
+ $self->diag("No tests run!\n");
_my_exit( 255 ) && return;
}
}
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
-See L<http://www.perl.com/perl/misc/Artistic.html>
+See F<http://www.perl.com/perl/misc/Artistic.html>
=cut
# actually happened.
sub _carp {
my($file, $line) = (caller(1))[1,2];
- warn @_, sprintf " at $file line $line\n";
+ warn @_, " at $file line $line\n";
}
require Exporter;
use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
-$VERSION = '0.33';
+$VERSION = '0.41';
@ISA = qw(Exporter);
@EXPORT = qw(ok use_ok require_ok
- is isnt like is_deeply
- skip todo
+ is isnt like unlike is_deeply
+ cmp_ok
+ skip todo todo_skip
pass fail
eq_array eq_hash eq_set
$TODO
plan
can_ok isa_ok
+ diag
);
my $Test = Test::Builder->new;
{
my $pkg = shift;
my $level = shift;
- (undef) = shift; # XXX redundant arg
+ (undef) = shift; # redundant arg
my $callpkg = caller($level);
$pkg->export($callpkg, @_);
}
is ($this, $that, $test_name);
isnt($this, $that, $test_name);
- like($this, qr/that/, $test_name);
+
+ # Rather than print STDERR "# here's what went wrong\n"
+ diag("here's what went wrong");
+
+ like ($this, qr/that/, $test_name);
+ unlike($this, qr/that/, $test_name);
+
+ cmp_ok($this, '==', $that, $test_name);
is_deeply($complex_structure1, $complex_structure2, $test_name);
=head1 DESCRIPTION
-If you're just getting started writing tests, have a look at
+B<STOP!> If you're just getting started writing tests, have a look at
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
-and compare complicated data structures.
+The purpose of this module is to provide a wide range of testing
+utilities. Various ways to say "ok" with better diagnostics,
+facilities to skip tests, test future features and compare complicated
+data structures. While you can do almost anything with a simple
+C<ok()> function, it doesn't provide good diagnostic output.
=head2 I love it when a plan comes together
}
sub isnt ($$;$) {
- my($this, $that, $name) = @_;
-
- my $test;
- {
- local $^W = 0; # so isnt(undef, undef) works quietly.
- $test = $this ne $that;
- }
-
- my $ok = $Test->ok($test, $name);
-
- unless( $ok ) {
- $that = defined $that ? "'$that'" : 'undef';
-
- $Test->diag(sprintf <<DIAGNOSTIC, $that);
-it should not be %s
-but it is.
-DIAGNOSTIC
-
- }
-
- return $ok;
+ $Test->isnt_eq(@_);
}
*isn't = \&isnt;
$Test->like(@_);
}
+
+=item B<unlike>
+
+ unlike( $this, qr/that/, $test_name );
+
+Works exactly as like(), only it checks if $this B<does not> match the
+given pattern.
+
+=cut
+
+sub unlike {
+ $Test->unlike(@_);
+}
+
+
+=item B<cmp_ok>
+
+ cmp_ok( $this, $op, $that, $test_name );
+
+Halfway between ok() and is() lies cmp_ok(). This allows you to
+compare two arguments using any binary perl operator.
+
+ # ok( $this eq $that );
+ cmp_ok( $this, 'eq', $that, 'this eq that' );
+
+ # ok( $this == $that );
+ cmp_ok( $this, '==', $that, 'this == that' );
+
+ # ok( $this && $that );
+ cmp_ok( $this, '&&', $that, 'this || that' );
+ ...etc...
+
+Its advantage over ok() is when the test fails you'll know what $this
+and $that were:
+
+ not ok 1
+ # Failed test (foo.t at line 12)
+ # '23'
+ # &&
+ # undef
+
+Its also useful in those cases where you are comparing numbers and
+is()'s use of C<eq> will interfere:
+
+ cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );
+
+=cut
+
+sub cmp_ok($$$;$) {
+ $Test->cmp_ok(@_);
+}
+
+
=item B<can_ok>
can_ok($module, @methods);
only without all the typing and with a better interface. Handy for
quickly testing an interface.
+No matter how many @methods you check, a single can_ok() call counts
+as one test. If you desire otherwise, use:
+
+ foreach my $meth (@methods) {
+ can_ok('Foo', $meth);
+ }
+
=cut
sub can_ok ($@) {
my($proto, @methods) = @_;
my $class= ref $proto || $proto;
+ unless( @methods ) {
+ my $ok = $Test->ok( 0, "$class->can(...)" );
+ $Test->diag(' can_ok() called with no methods');
+ return $ok;
+ }
+
my @nok = ();
foreach my $method (@methods) {
my $test = "'$class'->can('$method')";
+ local($!, $@); # don't interfere with caller's $@
+ # eval sometimes resets $!
eval $test || push @nok, $method;
}
my $ok = $Test->ok( !@nok, $name );
- $Test->diag(map "$class->can('$_') failed\n", @nok);
+ $Test->diag(map " $class->can('$_') failed\n", @nok);
return $ok;
}
=item B<isa_ok>
isa_ok($object, $class, $object_name);
+ isa_ok($ref, $type, $ref_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
to safeguard against your test script blowing up.
+It works on references, too:
+
+ isa_ok( $array_ref, 'ARRAY' );
+
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').
elsif( !ref $object ) {
$diag = "$obj_name isn't a reference";
}
- elsif( !$object->isa($class) ) {
- $diag = "$obj_name isn't a '$class'";
+ else {
+ # We can't use UNIVERSAL::isa because we want to honor isa() overrides
+ local($@, $!); # eval sometimes resets $!
+ my $rslt = eval { $object->isa($class) };
+ if( $@ ) {
+ if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
+ if( !UNIVERSAL::isa($object, $class) ) {
+ my $ref = ref $object;
+ $diag = "$obj_name isn't a '$class' its a '$ref'";
+ }
+ } else {
+ die <<WHOA;
+WHOA! I tried to call ->isa on your object and got some weird error.
+This should never happen. Please contact the author immediately.
+Here's the error.
+$@
+WHOA
+ }
+ }
+ elsif( !$rslt ) {
+ my $ref = ref $object;
+ $diag = "$obj_name isn't a '$class' its a '$ref'";
+ }
}
+
+
my $ok;
if( $diag ) {
$ok = $Test->ok( 0, $name );
- $Test->diag("$diag\n");
+ $Test->diag(" $diag\n");
}
else {
$ok = $Test->ok( 1, $name );
=back
+=head2 Diagnostics
+
+If you pick the right test function, you'll usually get a good idea of
+what went wrong when it failed. But sometimes it doesn't work out
+that way. So here we have ways for you to write your own diagnostic
+messages which are safer than just C<print STDERR>.
+
+=over 4
+
+=item B<diag>
+
+ diag(@diagnostic_message);
+
+Prints a diagnostic message which is guaranteed not to interfere with
+test output. Handy for this sort of thing:
+
+ ok( grep(/foo/, @users), "There's a foo user" ) or
+ diag("Since there's no foo, check that /etc/bar is set up right");
+
+which would produce:
+
+ not ok 42 - There's a foo user
+ # Failed test (foo.t at line 52)
+ # Since there's no foo, check that /etc/bar is set up right.
+
+You might remember C<ok() or diag()> with the mnemonic C<open() or
+die()>.
+
+B<NOTE> The exact formatting of the diagnostic output is still
+changing, but it is guaranteed that whatever you throw at it it won't
+interfere with the test.
+
+=cut
+
+sub diag {
+ $Test->diag(@_);
+}
+
+
+=back
+
=head2 Module tests
You usually want to test if the module you're testing loads ok, rather
my $pack = caller;
+ local($@,$!); # eval sometimes interferes with $!
eval <<USE;
package $pack;
require $module;
unless( $ok ) {
chomp $@;
$Test->diag(<<DIAGNOSTIC);
-Tried to use '$module'.
-Error: $@
+ Tried to use '$module'.
+ Error: $@
DIAGNOSTIC
}
my $pack = caller;
+ local($!, $@); # eval sometimes interferes with $!
eval <<REQUIRE;
package $pack;
require $module;
unless( $ok ) {
chomp $@;
$Test->diag(<<DIAGNOSTIC);
-# Tried to require '$module'.
-# Error: $@
+ Tried to require '$module'.
+ Error: $@
DIAGNOSTIC
}
=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
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 see L<Test::Harness>.
+For more details on the mechanics of 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
you're using C<no_plan>, 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
-feature (like fork() or symlinks) or maybe you need an Internet
-connection and one isn't available.
+Its perfectly safe to nest SKIP blocks.
+
+Tests are skipped when you B<never> expect them to B<ever> pass. 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.
+
+You don't skip tests which are failing because there's a bug in your
+program. For that you use TODO. Read on.
+
=for _Future
See L</Why are skip and todo so weird?>
=item B<TODO: BLOCK>
TODO: {
- local $TODO = $why;
+ local $TODO = $why if $condition;
...normal testing code goes here...
}
When the block is empty, delete it.
+=item B<todo_skip>
+
+ TODO: {
+ todo_skip $why, $how_many if $condition;
+
+ ...normal testing code...
+ }
+
+With todo tests, its best to have the tests actually run. That way
+you'll know when they start passing. Sometimes this isn't possible.
+Often a failing test will cause the whole program to die or hang, even
+inside an C<eval BLOCK> with and using C<alarm>. In these extreme
+cases you have no choice but to skip over the broken tests entirely.
+
+The syntax and behavior is similar to a C<SKIP: BLOCK> except the
+tests will be marked as failing but todo. Test::Harness will
+interpret them as passing.
+
+=cut
+
+sub todo_skip {
+ my($why, $how_many) = @_;
+
+ unless( defined $how_many ) {
+ # $how_many can only be avoided when no_plan is in use.
+ _carp "todo_skip() needs to know \$how_many tests are in the block"
+ unless $Test::Builder::No_Plan;
+ $how_many = 1;
+ }
+
+ for( 1..$how_many ) {
+ $Test->todo_skip($why);
+ }
+
+ local $^W = 0;
+ last TODO;
+}
+
+
=back
=head2 Comparison functions
see if they are equivalent. If the two structures are different, it
will display the place where they start differing.
+Barrie Slaymaker's Test::Differences module provides more in-depth
+functionality along these lines, and it plays well with Test::More.
+
B<NOTE> Display of scalar refs is not quite 100%
=cut
$out .= "$vars[0] = $vals[0]\n";
$out .= "$vars[1] = $vals[1]\n";
+ $out =~ s/^/ /msg;
return $out;
}
return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] );
}
-
=back
-=head1 NOTES
-Test::More is B<explicitly> tested all the way back to perl 5.004.
+=head2 Extending and Embedding Test::More
-=head1 BUGS and CAVEATS
+Sometimes the Test::More interface isn't quite enough. Fortunately,
+Test::More is built on top of Test::Builder which provides a single,
+unified backend for any test library to use. This means two test
+libraries which both use Test::Builder B<can be used together in the
+same program>.
+
+If you simply want to do a little tweaking of how the tests behave,
+you can access the underlying Test::Builder object like so:
=over 4
-=item Making your own ok()
+=item B<builder>
-This will not do what you mean:
+ my $test_builder = Test::More->builder;
- sub my_ok {
- ok( @_ );
- }
+Returns the Test::Builder object underlying Test::More for you to play
+with.
+
+=cut
- my_ok( 2 + 2 == 5, 'Basic addition' );
+sub builder {
+ return Test::Builder->new;
+}
-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:
+=back
- sub my_ok {
- ok( $_[0], $_[1] );
- }
-The other functions act similarly.
+=head1 NOTES
+
+Test::More is B<explicitly> tested all the way back to perl 5.004.
-=item The eq_* family have some caveats.
+=head1 BUGS and CAVEATS
+
+=over 4
+
+=item Making your own ok()
+
+If you are trying to extend Test::More, don't. Use Test::Builder
+instead.
+
+=item The eq_* family has some caveats.
=item Test::Harness upgrades
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.
+you're going to distribute tests that use no_plan or todo your
+end-users will have to upgrade Test::Harness to the latest one on
+CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness
+will work fine.
If you simply depend on Test::More, it's own dependencies will cause a
Test::Harness upgrade.
some tests. You can upgrade to Test::More later (its forward
compatible).
-L<Test> for a similar testing module.
+L<Test::Differences> for more ways to test complex data structures.
+And it plays well with Test::More.
+
+L<Test> is the old testing module. Its main benefit is that it has
+been distributed with Perl since 5.004_05.
L<Test::Harness> for details on how your test results are interpreted
by Perl.
=head1 AUTHORS
-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.
+Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration
+from Joshua Pritikin's Test module and lots of help from Barrie
+Slaymaker, Tony Bowden, chromatic and the perl-qa gang.
=head1 COPYRIGHT
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
-See L<http://www.perl.com/perl/misc/Artistic.html>
+See F<http://www.perl.com/perl/misc/Artistic.html>
=cut
use strict 'vars';
use vars qw($VERSION);
-$VERSION = '0.33';
+$VERSION = '0.41';
use Test::Builder;
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
-See L<http://www.perl.com/perl/misc/Artistic.html>
+See F<http://www.perl.com/perl/misc/Artistic.html>
=cut
Revision history for Perl extension Test::Simple
+0.41 Mon Dec 17 22:45:20 EST 2001
+ * chromatic added diag()
+ - Internal eval()'s sometimes interfering with $@ and $!. Fixed.
+
+0.40 Fri Dec 14 15:41:39 EST 2001
+ * isa_ok() now accepts unblessed references gracefully
+ - Nick Clark found a bug with like() and a regex with % in it.
+ - exit.t was hanging on 5.005_03 VMS perl. Test now skipped.
+ - can_ok() would pass if no methods were given. Now fails.
+ - isnt() diagnostic output format changed
+ * Added some docs about embedding and extending Test::More
+ * Added Test::More->builder
+ * Added cmp_ok()
+ * Added todo_skip()
+ * Added unlike()
+ - Piers pointed out that sometimes people override isa().
+ isa_ok() now accounts for that.
+
+0.36 Thu Nov 29 14:07:39 EST 2001
+ - Matthias Urlichs found that intermixed prints to STDOUT and test
+ output came out in the wrong order when piped.
+
+0.35 Tue Nov 27 19:57:03 EST 2001
+ - Little glitch in the test suite. No actual bug.
+
+0.34 Tue Nov 27 15:43:56 EST 2001
+ * Empty string no longer matches undef in is() and isnt().
+ * Added isnt_eq and isnt_num to Test::Builder.
+
0.33 Mon Oct 22 21:05:47 EDT 2001
* It's now officially safe to redirect STDOUT and STDERR without
affecting test output.
#!/usr/bin/perl -w
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
}
use Test::Builder;
#!perl -w
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
}
-use Test::More tests => 24;
+use Test::More tests => 37;
+
+# Make sure we don't mess with $@ or $!. Test at bottom.
+my $Err = "this should not be touched";
+my $Errno = 42;
+$@ = $Err;
+$! = $Errno;
use_ok('Text::Soundex');
require_ok('Test::More');
like("FooBle", '/foo/i', 'foo is like FooBle');
like("/usr/local/pr0n/", '/^\/usr\/local/', 'regexes with slashes in like' );
+unlike("fbar", '/^bar/', 'unlike bar');
+unlike("FooBle", '/foo/', 'foo is unlike FooBle');
+unlike("/var/local/pr0n/", '/^\/usr\/local/','regexes with slashes in unlike' );
+
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");
+isa_ok([], 'ARRAY');
+isa_ok(\42, 'SCALAR');
pass('pass() passed');
ok( !eq_hash(\%hash1, \%hash2),
'eq_hash with slightly different complicated hashes' );
+
+is( Test::Builder->new, Test::More->builder, 'builder()' );
+
+
+cmp_ok(42, '==', 42, 'cmp_ok ==');
+cmp_ok('foo', 'eq', 'foo', ' eq');
+cmp_ok(42.5, '<', 42.6, ' <');
+cmp_ok(0, '||', 1, ' ||');
+
+
+# Piers pointed out sometimes people override isa().
+{
+ package Wibble;
+ sub isa {
+ my($self, $class) = @_;
+ return 1 if $class eq 'Wibblemeister';
+ }
+ sub new { bless {} }
+}
+isa_ok( Wibble->new, 'Wibblemeister' );
+
+
+# These two tests must remain at the end.
+is( $@, $Err, '$@ untouched' );
+cmp_ok( $!, '==', $Errno, '$! untouched' );
--- /dev/null
+#!/usr/bin/perl
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+}
+
+# Ensure that intermixed prints to STDOUT and tests come out in the
+# right order (ie. no buffering problems).
+
+use Test::More tests => 20;
+my $T = Test::Builder->new;
+$T->no_ending(1);
+
+for my $num (1..10) {
+ $tnum = $num * 2;
+ pass("I'm ok");
+ $T->current_test($tnum);
+ print "ok $tnum - You're ok\n";
+}
+#!/usr/bin/perl
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+}
+
+# Ensure that intermixed prints to STDOUT and tests come out in the
+# right order (ie. no buffering problems).
+
+use Test::More tests => 20;
+my $T = Test::Builder->new;
+$T->no_ending(1);
+
+for my $num (1..10) {
+ $tnum = $num * 2;
+ pass("I'm ok");
+ $T->current_test($tnum);
+ print "ok $tnum - You're ok\n";
+}
--- /dev/null
+#!perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+}
+
+use strict;
+
+use Test::More tests => 5;
+
+my $Test = Test::More->builder;
+
+# now make a filehandle where we can send data
+my $output;
+tie *FAKEOUT, 'FakeOut', \$output;
+
+# force diagnostic output to a filehandle, glad I added this to Test::Builder :)
+my @lines;
+{
+ local $TODO = 1;
+ $Test->todo_output(\*FAKEOUT);
+
+ diag("a single line");
+
+ push @lines, $output;
+ $output = '';
+
+ diag("multiple\n", "lines");
+ push @lines, split(/\n/, $output);
+}
+
+is( @lines, 3, 'diag() should send messages to its filehandle' );
+like( $lines[0], '/^#\s+/', ' should add comment mark to all lines' );
+is( $lines[0], "# a single line\n", ' should send exact message' );
+is( $output, "# multiple\n# lines\n", ' should append multi messages');
+
+{
+ local $TODO = 1;
+ $output = '';
+ diag("# foo");
+}
+is( $output, "# # foo\n", "diag() adds a # even if there's one already" );
+
+
+package FakeOut;
+
+sub TIEHANDLE {
+ bless( $_[1], $_[0] );
+}
+
+sub PRINT {
+ my $self = shift;
+ $$self .= join('', @_);
+}
+#!perl -w
+
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+}
+
+use strict;
+
+use Test::More tests => 5;
+
+my $Test = Test::More->builder;
+
+# now make a filehandle where we can send data
+my $output;
+tie *FAKEOUT, 'FakeOut', \$output;
+
+# force diagnostic output to a filehandle, glad I added this to Test::Builder :)
+my @lines;
+{
+ local $TODO = 1;
+ $Test->todo_output(\*FAKEOUT);
+
+ diag("a single line");
+
+ push @lines, $output;
+ $output = '';
+
+ diag("multiple\n", "lines");
+ push @lines, split(/\n/, $output);
+}
+
+is( @lines, 3, 'diag() should send messages to its filehandle' );
+like( $lines[0], '/^#\s+/', ' should add comment mark to all lines' );
+is( $lines[0], "# a single line\n", ' should send exact message' );
+is( $output, "# multiple\n# lines\n", ' should append multi messages');
+
+{
+ local $TODO = 1;
+ $output = '';
+ diag("# foo");
+}
+is( $output, "# # foo\n", "diag() adds a # even if there's one already" );
+
+
+package FakeOut;
+
+sub TIEHANDLE {
+ bless( $_[1], $_[0] );
+}
+
+sub PRINT {
+ my $self = shift;
+ $$self .= join('', @_);
+}
-BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
-}
-
# Can't use Test.pm, that's a 5.005 thing.
package My::Test;
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+}
+
unless( eval { require File::Spec } ) {
print "1..0 # Skip Need File::Spec to run this test\n";
- exit(0);
+ exit 0;
+}
+
+if( $^O eq 'VMS' && $] <= 5.00503 ) {
+ print "1..0 # Skip test will hang on older VMS perls\n";
+ exit 0;
}
my $test_num = 1;
print "1..".keys(%Tests)."\n";
+chdir 't';
my $lib = File::Spec->catdir(qw(lib Test Simple sample_tests));
while( my($test_name, $exit_codes) = each %Tests ) {
my($exit_code) = $exit_codes->[$IsVMS ? 1 : 0];
+ my $Perl = $^X;
+
+ if( $^O eq 'VMS' ) {
+ # VMS can't use its own $^X in a system call until almost 5.8
+ $Perl = "MCR $^X" if $] < 5.007003;
+
+ # Quiet noisy 'SYS$ABORT'. 'hushed' only exists in 5.6 and up,
+ # but it doesn't do any harm on eariler perls.
+ $Perl .= q{ -"Mvmsish=hushed"};
+ }
+
my $file = File::Spec->catfile($lib, $test_name);
- my $wait_stat = system(qq{$^X -"I../lib" -"I../t/lib" $file});
+ my $wait_stat = system(qq{$Perl -"I../blib/lib" -"I../lib" -"I../t/lib" $file});
my $actual_exit = $wait_stat >> 8;
My::Test::ok( $actual_exit == $exit_code,
#!perl -w
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
}
# Can't use Test.pm, that's a 5.005 thing.
require Test::Simple;
+chdir 't';
push @INC, '../t/lib/';
require Test::Simple::Catch;
my($out, $err) = Test::Simple::Catch::caught();
}
}
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
# There was a bug with like() involving a qr// not failing properly.
# This tests against that.
-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();
#!perl -w
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
}
use strict;
-use lib '../t/lib';
require Test::Simple::Catch;
my($out, $err) = Test::Simple::Catch::caught();
package main;
require Test::More;
-Test::More->import(tests => 12);
+my $Total = 28;
+Test::More->import(tests => $Total);
# Preserve the line numbers.
#line 38
ok( 0, 'failing' );
-is( "foo", "bar", 'foo is bar?');
+
+#line 40
+is( "foo", "bar", 'foo is bar?');
+is( undef, '', 'undef is empty string?');
+is( undef, 0, 'undef is 0?');
+is( '', 0, 'empty string is 0?' );
+
isnt("foo", "foo", 'foo isnt foo?' );
isn't("foo", "foo",'foo isn\'t foo?' );
like( "foo", '/that/', 'is foo like that' );
+unlike( "foo", '/foo/', 'is foo unlike foo' );
+
+# Nick Clark found this was a bug. Fixed in 0.40.
+like( "bug", '/(%)/', 'regex with % in it' );
fail('fail()');
+#line 52
can_ok('Mooble::Hooble::Yooble', qw(this that));
+can_ok('Mooble::Hooble::Yooble', ());
+
isa_ok(bless([], "Foo"), "Wibble");
isa_ok(42, "Wibble", "My Wibble");
isa_ok(undef, "Wibble", "Another Wibble");
-
+isa_ok([], "HASH");
+
+#line 68
+cmp_ok( 'foo', 'eq', 'bar', 'cmp_ok eq' );
+cmp_ok( 42.1, '==', 23, , ' ==' );
+cmp_ok( 42, '!=', 42 , ' !=' );
+cmp_ok( 1, '&&', 0 , ' &&' );
+cmp_ok( 42, '==', "foo", ' == with strings' );
+cmp_ok( 42, 'eq', "foo", ' eq with numbers' );
+cmp_ok( undef, 'eq', 'foo', ' eq with undef' );
+
+# generate a $!, it changes its value by context.
+-e "wibblehibble";
+my $Errno_Number = $!+0;
+my $Errno_String = $!.'';
+cmp_ok( $!, 'eq', '', ' eq with stringified errno' );
+cmp_ok( $!, '==', -1, ' eq with numerified errno' );
+
+#line 84
use_ok('Hooble::mooble::yooble');
require_ok('ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble');
+#line 88
END {
My::Test::ok($$out eq <<OUT, 'failing output');
-1..12
+1..$Total
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 - Mooble::Hooble::Yooble->can(...)
-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;
+not ok 3 - undef is empty string?
+not ok 4 - undef is 0?
+not ok 5 - empty string is 0?
+not ok 6 - foo isnt foo?
+not ok 7 - foo isn't foo?
+not ok 8 - is foo like that
+not ok 9 - is foo unlike foo
+not ok 10 - regex with % in it
+not ok 11 - fail()
+not ok 12 - Mooble::Hooble::Yooble->can(...)
+not ok 13 - Mooble::Hooble::Yooble->can(...)
+not ok 14 - The object isa Wibble
+not ok 15 - My Wibble isa Wibble
+not ok 16 - Another Wibble isa Wibble
+not ok 17 - The object isa HASH
+not ok 18 - cmp_ok eq
+not ok 19 - ==
+not ok 20 - !=
+not ok 21 - &&
+not ok 22 - == with strings
+not ok 23 - eq with numbers
+not ok 24 - eq with undef
+not ok 25 - eq with stringified errno
+not ok 26 - eq with numerified errno
+not ok 27 - use Hooble::mooble::yooble;
+not ok 28 - require ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble;
OUT
my $err_re = <<ERR;
# Failed test ($0 at line 38)
-# Failed test ($0 at line 39)
+# Failed test ($0 at line 40)
# got: 'foo'
# expected: 'bar'
-# Failed test ($0 at line 40)
-# it should not be 'foo'
-# but it is.
# Failed test ($0 at line 41)
-# it should not be 'foo'
-# but it is.
+# got: undef
+# expected: ''
+# Failed test ($0 at line 42)
+# got: undef
+# expected: '0'
# Failed test ($0 at line 43)
+# got: ''
+# expected: '0'
+# Failed test ($0 at line 45)
+# 'foo'
+# ne
+# 'foo'
+# Failed test ($0 at line 46)
+# 'foo'
+# ne
+# 'foo'
+# Failed test ($0 at line 48)
# 'foo'
# doesn't match '/that/'
-# Failed test ($0 at line 45)
-# Failed test ($0 at line 47)
+# Failed test ($0 at line 49)
+# 'foo'
+# matches '/foo/'
+# Failed test ($0 at line 52)
+# 'bug'
+# doesn't match '/(%)/'
+# Failed test ($0 at line 54)
+# Failed test ($0 at line 52)
# Mooble::Hooble::Yooble->can('this') failed
# Mooble::Hooble::Yooble->can('that') failed
-# Failed test ($0 at line 48)
-# The object isn't a 'Wibble'
-# Failed test ($0 at line 49)
+# Failed test ($0 at line 53)
+# can_ok() called with no methods
+# Failed test ($0 at line 55)
+# The object isn't a 'Wibble' its a 'Foo'
+# Failed test ($0 at line 56)
# My Wibble isn't a reference
-# Failed test ($0 at line 50)
+# Failed test ($0 at line 57)
# Another Wibble isn't defined
+# Failed test ($0 at line 58)
+# The object isn't a 'HASH' its a 'ARRAY'
+# Failed test ($0 at line 68)
+# got: 'foo'
+# expected: 'bar'
+# Failed test ($0 at line 69)
+# got: 42.1
+# expected: 23
+# Failed test ($0 at line 70)
+# '42'
+# !=
+# '42'
+# Failed test ($0 at line 71)
+# '1'
+# &&
+# '0'
+# Failed test ($0 at line 72)
+# got: 42
+# expected: 0
+# Failed test ($0 at line 73)
+# got: '42'
+# expected: 'foo'
+# Failed test ($0 at line 74)
+# got: undef
+# expected: 'foo'
+# Failed test ($0 at line 80)
+# got: '$Errno_String'
+# expected: ''
+# Failed test ($0 at line 81)
+# got: $Errno_Number
+# expected: -1
ERR
my $filename = quotemeta $0;
my $more_err_re = <<ERR;
-# Failed test \\($filename at line 52\\)
+# Failed test \\($filename at line 84\\)
# Tried to use 'Hooble::mooble::yooble'.
# Error: Can't locate Hooble.* in \\\@INC .*
-# Failed test \\($filename at line 53\\)
+# Failed test \\($filename at line 85\\)
# Tried to require 'ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble'.
# Error: Can't locate ALL.* in \\\@INC .*
-# Looks like you failed 12 tests of 12.
+# Looks like you failed $Total tests of $Total.
ERR
unless( My::Test::ok($$err =~ /^\Q$err_re\E$more_err_re$/,
'failing errors') ) {
- print map "# $_", $$err;
+ print $$err;
}
exit(0);
#!perl -w
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
}
use strict;
-use lib qw(../t/lib);
require Test::Simple::Catch;
my($out, $err) = Test::Simple::Catch::caught();
#!perl -w
+BEGIN {
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
+}
+
use Test::More tests => 1;
tie *STDOUT, "Dev::Null" or die $!;
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
}
+
use Test::More tests => 2, import => [qw(!fail)];
can_ok(__PACKAGE__, qw(ok pass like isa_ok));
-#!perl -w
+#!/usr/bin/perl -w
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
}
use strict;
-use lib qw(../t/lib);
use Test::Builder;
require Test::Simple::Catch;
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
}
# Can't use Test.pm, that's a 5.005 thing.
require Test::Simple;
-push @INC, '../t/lib';
require Test::Simple::Catch;
my($out, $err) = Test::Simple::Catch::caught();
+use Test::Builder;
+
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
}
-use Test::Builder;
-
BEGIN {
my $t = Test::Builder->new;
$t->no_ending(1);
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
}
-# STDOUT must be unbuffered else our prints might come out after
-# Test::More's.
-$| = 1;
-
use Test::Builder;
# STDOUT must be unbuffered else our prints might come out after
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
}
# Can't use Test.pm, that's a 5.005 thing.
require Test::Simple;
-push @INC, '../t/lib';
require Test::Simple::Catch;
my($out, $err) = Test::Simple::Catch::caught();
#!perl -w
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
}
# Can't use Test.pm, that's a 5.005 thing.
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
}
use Test::More;
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/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 {
+ if( !$ENV{HARNESS_ACTIVE} && $ENV{PERL_CORE} ) {
+ print "1..0 # Skipped: Won't work with t/TEST\n";
+ exit 0;
+ }
+
+ # This feature requires a fairly new version of Test::Harness
require Test::Harness;
if( $Test::Harness::VERSION < 1.20 ) {
print "1..0 # Skipped: Need Test::Harness 1.20 or up\n";
require Test::Simple;
-push @INC, '../t/lib';
require Test::Simple::Catch;
my($out, $err) = Test::Simple::Catch::caught();
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
}
-# Can't use Test.pm, that's a 5.005 thing.
-package My::Test;
+use Test::More;
-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++;
+BEGIN {
+ if( !$ENV{HARNESS_ACTIVE} && $ENV{PERL_CORE} ) {
+ plan skip_all => "Won't work with t/TEST";
+ }
}
-
-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');
+ 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');
+ plan 'no_plan';
}
pass('Just testing');
ok(1, 'Testing again');
-
-END {
- My::Test::ok($$out eq <<OUT);
-ok 1 - Just testing
-ok 2 - Testing again
-1..2
-OUT
-
- My::Test::ok($$err eq '');
-}
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
}
use Test::More;
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
}
use strict;
#!perl -w
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
}
use Test::More tests => 15;
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
-}
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = ('../lib', 'lib');
+ }
+ else {
+ unshift @INC, 't/lib';
+ }
+}
use strict;
package main;
require Test::More;
-push @INC, '../t/lib';
require Test::Simple::Catch;
my($out, $err) = Test::Simple::Catch::caught();
#!perl -w
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
}
BEGIN {
require Test::Harness;
- require Test::More;
+ use Test::More;
if( $Test::Harness::VERSION < 1.23 ) {
- Test::More->import(skip_all => 'Need Test::Harness 1.23 or up');
+ plan skip_all => 'Need Test::Harness 1.23 or up';
}
else {
- Test::More->import(tests => 13);
+ plan tests => 15;
}
}
use_ok('Fooble');
require_ok('Fooble');
}
+
+
+TODO: {
+ todo_skip "Just testing todo_skip", 2;
+
+ fail("Just testing todo");
+ die "todo_skip should prevent this";
+ pass("Again");
+}
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
}
use strict;
-use Test::More tests => 10;
+use Test::More tests => 12;
BEGIN { $^W = 1; }
my $warnings = '';
-local $SIG{__WARN__} = sub { $warnings = join '', @_ };
+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' );
+isnt( undef, '', 'undef isnt an empty string' );
+isnt( undef, 0, 'undef isnt zero' );
+
like( undef, '/.*/', 'undef is like anything' );
is( $warnings, '', ' no warnings' );
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
}
use Test::More tests => 7;
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib';
+ if( $ENV{PERL_CORE} ) {
+ chdir 't';
+ @INC = '../lib';
+ }
}
use Test::More tests => 5;
=head2 Test the manual
Simplest way to build up a decent testing suite is to just test what
-the manual says it does. [3] Let's pull something out of the
-L<Date::ICal/SYNOPSIS> and test that all it's bits work.
+the manual says it does. [3] Let's pull something out of the
+L<Date::ICal/SYNOPSIS> and test that all its bits work.
#!/usr/bin/perl -w
projects / p5sagit/p5-mst-13.2.git / commitdiff