dslinux/user/perl/lib/Test/Simple/t 00test_harness_check.t Builder.t More.t bad_plan.t bail_out.t buffer.t circular_data.t create.t curr_test.t details.t diag.t eq_set.t exit.t extra.t extra_one.t fail-like.t fail-more.t fail.t fail_one.t filehandles.t fork.t harness_active.t has_plan.t has_plan2.t import.t is_deeply_fail.t is_fh.t maybe_regex.t missing.t no_diag.t no_ending.t no_header.t no_plan.t ok_obj.t output.t overload.t overload_threads.t plan.t plan_bad.t plan_is_noplan.t plan_no_plan.t plan_shouldnt_import.t plan_skip_all.t require_ok.t reset.t simple.t skip.t skipall.t sort_bug.t strays.t tbt_01basic.t tbt_02fhrestore.t tbt_03die.t tbt_04line_num.t tbt_05faildiag.t tbt_06errormess.t tbt_07args.t thread_taint.t threads.t todo.t undef.t use_ok.t useing.t
cayenne
dslinux_cayenne at user.in-berlin.de
Mon Dec 4 18:01:10 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/lib/Test/Simple/t
In directory antilope:/tmp/cvs-serv17422/lib/Test/Simple/t
Added Files:
00test_harness_check.t Builder.t More.t bad_plan.t bail_out.t
buffer.t circular_data.t create.t curr_test.t details.t diag.t
eq_set.t exit.t extra.t extra_one.t fail-like.t fail-more.t
fail.t fail_one.t filehandles.t fork.t harness_active.t
has_plan.t has_plan2.t import.t is_deeply_fail.t is_fh.t
maybe_regex.t missing.t no_diag.t no_ending.t no_header.t
no_plan.t ok_obj.t output.t overload.t overload_threads.t
plan.t plan_bad.t plan_is_noplan.t plan_no_plan.t
plan_shouldnt_import.t plan_skip_all.t require_ok.t reset.t
simple.t skip.t skipall.t sort_bug.t strays.t tbt_01basic.t
tbt_02fhrestore.t tbt_03die.t tbt_04line_num.t
tbt_05faildiag.t tbt_06errormess.t tbt_07args.t thread_taint.t
threads.t todo.t undef.t use_ok.t useing.t
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: overload_threads.t ---
#!perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
chdir 't';
BEGIN {
# There was a bug with overloaded objects and threads.
# See rt.cpan.org 4218
eval { require threads; 'threads'->import; 1; };
}
use Test::More;
BEGIN {
if( !eval "require overload" ) {
plan skip_all => "needs overload.pm";
}
else {
plan tests => 5;
}
}
package Overloaded;
use overload
q{""} => sub { $_[0]->{string} };
sub new {
my $class = shift;
bless { string => shift }, $class;
}
package main;
my $warnings = '';
local $SIG{__WARN__} = sub { $warnings = join '', @_ };
# overloaded object as name
my $obj = Overloaded->new('foo');
ok( 1, $obj );
# overloaded object which returns undef as name
my $undef = Overloaded->new(undef);
pass( $undef );
is( $warnings, '' );
TODO: {
my $obj = Overloaded->new('not really todo, testing overloaded reason');
local $TODO = $obj;
fail("Just checking todo as an overloaded value");
}
SKIP: {
my $obj = Overloaded->new('not really skipped, testing overloaded reason');
skip $obj, 1;
}
--- NEW FILE: fail_one.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use strict;
require Test::Simple::Catch;
my($out, $err) = Test::Simple::Catch::caught();
local $ENV{HARNESS_ACTIVE} = 0;
# 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++;
return $test ? 1 : 0;
}
package main;
require Test::Simple;
Test::Simple->import(tests => 1);
#line 45
ok(0);
END {
My::Test::ok($$out eq <<OUT);
1..1
not ok 1
OUT
My::Test::ok($$err eq <<ERR) || print $$err;
# Failed test in $0 at line 45.
# Looks like you failed 1 test of 1.
ERR
# Prevent Test::Simple from existing with non-zero
exit 0;
}
--- NEW FILE: create.t ---
#!/usr/bin/perl -w
#!perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use Test::More tests => 8;
use Test::Builder;
my $more_tb = Test::More->builder;
isa_ok $more_tb, 'Test::Builder';
is $more_tb, Test::More->builder, 'create does not interfere with ->builder';
is $more_tb, Test::Builder->new, ' does not interfere with ->new';
{
my $new_tb = Test::Builder->create;
isa_ok $new_tb, 'Test::Builder';
isnt $more_tb, $new_tb, 'Test::Builder->create makes a new object';
$new_tb->output("some_file");
END { 1 while unlink "some_file" }
$new_tb->plan(tests => 1);
$new_tb->ok(1);
}
pass("Changing output() of new TB doesn't interfere with singleton");
ok open FILE, "some_file";
is join("", <FILE>), <<OUT;
1..1
ok 1
OUT
close FILE;
--- NEW FILE: is_fh.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use strict;
use Test::More tests => 8;
use TieOut;
ok( !Test::Builder::_is_fh("foo"), 'string is not a filehandle' );
ok( !Test::Builder::_is_fh(''), 'empty string' );
ok( !Test::Builder::_is_fh(undef), 'undef' );
ok( open(FILE, '>foo') );
END { close FILE; unlink 'foo' }
ok( Test::Builder::_is_fh(*FILE) );
ok( Test::Builder::_is_fh(\*FILE) );
ok( Test::Builder::_is_fh(*FILE{IO}) );
tie *OUT, 'TieOut';
ok( Test::Builder::_is_fh(*OUT) );
--- NEW FILE: plan_skip_all.t ---
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Test::More;
plan skip_all => 'Just testing plan & skip_all';
fail('We should never get here');
--- NEW FILE: diag.t ---
#!perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
# Turn on threads here, if available, since this test tends to find
# lots of threading bugs.
use Config;
BEGIN {
if( $] >= 5.008 && $Config{useithreads} ) {
require threads;
'threads'->import;
}
}
use strict;
use Test::More tests => 5;
my $Test = Test::More->builder;
# now make a filehandle where we can send data
use TieOut;
my $output = tie *FAKEOUT, 'TieOut';
# force diagnostic output to a filehandle, glad I added this to
# Test::Builder :)
my $ret;
{
local $TODO = 1;
$Test->todo_output(\*FAKEOUT);
diag("a single line");
$ret = diag("multiple\n", "lines");
}
is( $output->read, <<'DIAG', 'diag() with todo_output set' );
# a single line
# multiple
# lines
DIAG
ok( !$ret, 'diag returns false' );
{
$Test->failure_output(\*FAKEOUT);
$ret = diag("# foo");
}
$Test->failure_output(\*STDERR);
is( $output->read, "# # foo\n", "diag() adds # even if there's one already" );
ok( !$ret, 'diag returns false' );
# [rt.cpan.org 8392]
{
$Test->failure_output(\*FAKEOUT);
diag(qw(one two));
}
$Test->failure_output(\*STDERR);
is( $output->read, <<'DIAG' );
# onetwo
DIAG
--- NEW FILE: extra.t ---
#!perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
# Can't use Test.pm, that's a 5.005 thing.
package My::Test;
# This has to be a require or else the END block below runs before
# Test::Builder's own and the ending diagnostics don't come out right.
require Test::Builder;
my $TB = Test::Builder->create;
$TB->plan(tests => 2);
package main;
require Test::Simple;
chdir 't';
push @INC, '../t/lib/';
require Test::Simple::Catch;
my($out, $err) = Test::Simple::Catch::caught();
local $ENV{HARNESS_ACTIVE} = 0;
Test::Simple->import(tests => 3);
#line 30
ok(1, 'Foo');
ok(0, 'Bar');
ok(1, 'Yar');
ok(1, 'Car');
ok(0, 'Sar');
END {
$TB->is_eq($$out, <<OUT);
1..3
ok 1 - Foo
not ok 2 - Bar
ok 3 - Yar
ok 4 - Car
not ok 5 - Sar
OUT
$TB->is_eq($$err, <<ERR);
# Failed test 'Bar'
# in $0 at line 31.
# Failed test 'Sar'
# in $0 at line 34.
# Looks like you planned 3 tests but ran 2 extra.
# Looks like you failed 2 tests of 5 run.
ERR
exit 0;
}
--- NEW FILE: eq_set.t ---
#!perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
chdir 't';
use strict;
use Test::More;
plan tests => 4;
# RT 3747
ok( eq_set([1, 2, [3]], [[3], 1, 2]) );
ok( eq_set([1,2,[3]], [1,[3],2]) );
# bugs.perl.org 36354
my $ref = \2;
ok( eq_set( [$ref, "$ref", "$ref", $ref],
["$ref", $ref, $ref, "$ref"]
) );
TODO: {
local $TODO = q[eq_set() doesn't really handle references];
ok( eq_set( [\1, \2, \3], [\2, \3, \1] ) );
}
--- NEW FILE: fail-more.t ---
#!perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use strict;
require Test::Simple::Catch;
my($out, $err) = Test::Simple::Catch::caught();
local $ENV{HARNESS_ACTIVE} = 0;
# Can't use Test.pm, that's a 5.005 thing.
package My::Test;
# This has to be a require or else the END block below runs before
# Test::Builder's own and the ending diagnostics don't come out right.
require Test::Builder;
my $TB = Test::Builder->create;
$TB->plan(tests => 17);
sub like ($$;$) {
$TB->like(@_);
}
sub is ($$;$) {
$TB->is_eq(@_);
}
sub main::err_ok ($) {
my($expect) = @_;
my $got = $err->read;
return $TB->is_eq( $got, $expect );
}
package main;
require Test::More;
my $Total = 28;
Test::More->import(tests => $Total);
my $tb = Test::More->builder;
$tb->use_numbers(0);
my $Filename = quotemeta $0;
# Preserve the line numbers.
#line 38
ok( 0, 'failing' );
err_ok( <<ERR );
# Failed test 'failing'
# in $0 at line 38.
ERR
#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?' );
err_ok( <<ERR );
# Failed test 'foo is bar?'
# in $0 at line 40.
# got: 'foo'
# expected: 'bar'
# Failed test 'undef is empty string?'
# in $0 at line 41.
# got: undef
# expected: ''
# Failed test 'undef is 0?'
# in $0 at line 42.
# got: undef
# expected: '0'
# Failed test 'empty string is 0?'
# in $0 at line 43.
# got: ''
# expected: '0'
ERR
#line 45
isnt("foo", "foo", 'foo isnt foo?' );
isn't("foo", "foo",'foo isn\'t foo?' );
isnt(undef, undef, 'undef isnt undef?');
err_ok( <<ERR );
# Failed test 'foo isnt foo?'
# in $0 at line 45.
# 'foo'
# ne
# 'foo'
# Failed test 'foo isn\'t foo?'
# in $0 at line 46.
# 'foo'
# ne
# 'foo'
# Failed test 'undef isnt undef?'
# in $0 at line 47.
# undef
# ne
# undef
ERR
#line 48
like( "foo", '/that/', 'is foo like that' );
unlike( "foo", '/foo/', 'is foo unlike foo' );
err_ok( <<ERR );
# Failed test 'is foo like that'
# in $0 at line 48.
# 'foo'
# doesn't match '/that/'
# Failed test 'is foo unlike foo'
# in $0 at line 49.
# 'foo'
# matches '/foo/'
ERR
# Nick Clark found this was a bug. Fixed in 0.40.
# line 60
like( "bug", '/(%)/', 'regex with % in it' );
err_ok( <<ERR );
# Failed test 'regex with % in it'
# in $0 at line 60.
# 'bug'
# doesn't match '/(%)/'
ERR
#line 67
fail('fail()');
err_ok( <<ERR );
# Failed test 'fail()'
# in $0 at line 67.
ERR
#line 52
can_ok('Mooble::Hooble::Yooble', qw(this that));
can_ok('Mooble::Hooble::Yooble', ());
err_ok( <<ERR );
# Failed test 'Mooble::Hooble::Yooble->can(...)'
# in $0 at line 52.
# Mooble::Hooble::Yooble->can('this') failed
# Mooble::Hooble::Yooble->can('that') failed
# Failed test 'Mooble::Hooble::Yooble->can(...)'
# in $0 at line 53.
# can_ok() called with no methods
ERR
#line 55
isa_ok(bless([], "Foo"), "Wibble");
isa_ok(42, "Wibble", "My Wibble");
isa_ok(undef, "Wibble", "Another Wibble");
isa_ok([], "HASH");
err_ok( <<ERR );
# Failed test 'The object isa Wibble'
# in $0 at line 55.
# The object isn't a 'Wibble' it's a 'Foo'
# Failed test 'My Wibble isa Wibble'
# in $0 at line 56.
# My Wibble isn't a reference
# Failed test 'Another Wibble isa Wibble'
# in $0 at line 57.
# Another Wibble isn't defined
# Failed test 'The object isa HASH'
# in $0 at line 58.
# The object isn't a 'HASH' it's a 'ARRAY'
ERR
#line 68
cmp_ok( 'foo', 'eq', 'bar', 'cmp_ok eq' );
cmp_ok( 42.1, '==', 23, , ' ==' );
cmp_ok( 42, '!=', 42 , ' !=' );
cmp_ok( 1, '&&', 0 , ' &&' );
err_ok( <<ERR );
# Failed test 'cmp_ok eq'
# in $0 at line 68.
# got: 'foo'
# expected: 'bar'
# Failed test ' =='
# in $0 at line 69.
# got: 42.1
# expected: 23
# Failed test ' !='
# in $0 at line 70.
# '42'
# !=
# '42'
# Failed test ' &&'
# in $0 at line 71.
# '1'
# &&
# '0'
ERR
# line 196
cmp_ok( 42, 'eq', "foo", ' eq with numbers' );
err_ok( <<ERR );
# Failed test ' eq with numbers'
# in $0 at line 196.
# got: '42'
# expected: 'foo'
ERR
{
my $warnings;
local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
# line 211
cmp_ok( 42, '==', "foo", ' == with strings' );
err_ok( <<ERR );
# Failed test ' == with strings'
# in $0 at line 211.
# got: 42
# expected: foo
ERR
My::Test::like $warnings,
qq[/^Argument "foo" isn't numeric in .* at $Filename line 211\\\.\n\$/];
}
# generate a $!, it changes its value by context.
-e "wibblehibble";
my $Errno_Number = $!+0;
my $Errno_String = $!.'';
#line 80
cmp_ok( $!, 'eq', '', ' eq with stringified errno' );
cmp_ok( $!, '==', -1, ' eq with numerified errno' );
err_ok( <<ERR );
# Failed test ' eq with stringified errno'
# in $0 at line 80.
# got: '$Errno_String'
# expected: ''
# Failed test ' eq with numerified errno'
# in $0 at line 81.
# got: $Errno_Number
# expected: -1
ERR
#line 84
use_ok('Hooble::mooble::yooble');
my $more_err_re = <<ERR;
# Failed test 'use Hooble::mooble::yooble;'
# in $Filename at line 84\\.
# Tried to use 'Hooble::mooble::yooble'.
# Error: Can't locate Hooble.* in \\\@INC .*
# BEGIN failed--compilation aborted at $Filename line 84.
ERR
My::Test::like($err->read, "/^$more_err_re/");
#line 85
require_ok('ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble');
$more_err_re = <<ERR;
# Failed test 'require ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble;'
# in $Filename at line 85\\.
# Tried to require 'ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble'.
# Error: Can't locate ALL.* in \\\@INC .*
ERR
My::Test::like($err->read, "/^$more_err_re/");
#line 88
END {
$TB->is_eq($$out, <<OUT, 'failing output');
1..$Total
not ok - failing
not ok - foo is bar?
not ok - undef is empty string?
not ok - undef is 0?
not ok - empty string is 0?
not ok - foo isnt foo?
not ok - foo isn't foo?
not ok - undef isnt undef?
not ok - is foo like that
not ok - is foo unlike foo
not ok - regex with % in it
not ok - fail()
not ok - Mooble::Hooble::Yooble->can(...)
not ok - Mooble::Hooble::Yooble->can(...)
not ok - The object isa Wibble
not ok - My Wibble isa Wibble
not ok - Another Wibble isa Wibble
not ok - The object isa HASH
not ok - cmp_ok eq
not ok - ==
not ok - !=
not ok - &&
not ok - eq with numbers
not ok - == with strings
not ok - eq with stringified errno
not ok - eq with numerified errno
not ok - use Hooble::mooble::yooble;
not ok - require ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble;
OUT
err_ok( <<ERR );
# Looks like you failed $Total tests of $Total.
ERR
exit(0);
}
--- NEW FILE: sort_bug.t ---
#!/usr/bin/perl -w
# Test to see if we've worked around some wacky sort/threading bug
# See [rt.cpan.org 6782]
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use strict;
use Config;
BEGIN {
unless ( $] >= 5.008 && $Config{'useithreads'} &&
eval { require threads; 'threads'->import; 1; })
{
print "1..0 # Skip: no threads\n";
exit 0;
}
}
use Test::More;
# Passes with $nthreads = 1 and with eq_set().
# Passes with $nthreads = 2 and with eq_array().
# Fails with $nthreads = 2 and with eq_set().
my $Num_Threads = 2;
plan tests => $Num_Threads;
sub do_one_thread {
my $kid = shift;
my @list = ( 'x', 'yy', 'zzz', 'a', 'bb', 'ccc', 'aaaaa', 'z',
'hello', 's', 'thisisalongname', '1', '2', '3',
'abc', 'xyz', '1234567890', 'm', 'n', 'p' );
my @list2 = @list;
print "# kid $kid before eq_set\n";
for my $j (1..99) {
# With eq_set, either crashes or panics
eq_set(\@list, \@list2);
eq_array(\@list, \@list2);
}
print "# kid $kid exit\n";
return 42;
}
my @kids = ();
for my $i (1..$Num_Threads) {
my $t = threads->new(\&do_one_thread, $i);
print "# parent $$: continue\n";
push(@kids, $t);
}
for my $t (@kids) {
print "# parent $$: waiting for join\n";
my $rc = $t->join();
cmp_ok( $rc, '==', 42, "threads exit status is $rc" );
}
--- NEW FILE: plan_bad.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
# Can't use Test.pm, that's a 5.005 thing.
package My::Test;
print "1..7\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++;
return $test;
}
sub is ($$;$) {
my($this, $that, $name) = @_;
my $test = $this eq $that;
my $ok = '';
$ok .= "not " unless $test;
$ok .= "ok $test_num";
$ok .= " - $name" if defined $name;
$ok .= "\n";
print $ok;
unless( $test ) {
print "# got \n$this";
print "# expected \n$that";
}
$test_num++;
return $test;
}
use Test::More import => ['plan'];
ok !eval { plan tests => 'no_plan'; };
is $@, "Number of tests must be a postive integer. You gave it 'no_plan'.\n";
my $foo = [];
my @foo = ($foo, 2, 3);
ok !eval { plan tests => @foo };
is $@, "Number of tests must be a postive integer. You gave it '$foo'.\n";
ok !eval { plan tests => 0 };
ok !eval { plan tests => -1 };
ok !eval { plan tests => '' };
--- NEW FILE: no_diag.t ---
#!/usr/bin/perl -w
use Test::More 'no_diag', tests => 2;
pass('foo');
diag('This should not be displayed');
is(Test::More->builder->no_diag, 1);
--- NEW FILE: thread_taint.t ---
#!/usr/bin/perl -w
use Test::More tests => 1;
ok( !$INC{'threads.pm'}, 'Loading Test::More does not load threads.pm' );
--- NEW FILE: harness_active.t ---
#!perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use strict;
use Test::Simple::Catch;
my($out, $err) = Test::Simple::Catch::caught();
# Can't use Test.pm, that's a 5.005 thing.
package My::Test;
# This has to be a require or else the END block below runs before
# Test::Builder's own and the ending diagnostics don't come out right.
require Test::Builder;
my $TB = Test::Builder->create;
$TB->plan(tests => 4);
# Utility testing functions.
sub ok ($;$) {
return $TB->ok(@_);
}
sub main::err_ok ($) {
my($expect) = @_;
my $got = $err->read;
return $TB->is_eq( $got, $expect );
}
package main;
require Test::More;
Test::More->import(tests => 4);
Test::More->builder->no_ending(1);
{
local $ENV{HARNESS_ACTIVE} = 0;
#line 62
fail( "this fails" );
err_ok( <<ERR );
# Failed test 'this fails'
# in $0 at line 62.
ERR
#line 72
is( 1, 0 );
err_ok( <<ERR );
# Failed test in $0 at line 72.
# got: '1'
# expected: '0'
ERR
}
{
local $ENV{HARNESS_ACTIVE} = 1;
#line 71
fail( "this fails" );
err_ok( <<ERR );
# Failed test 'this fails'
# in $0 at line 71.
ERR
#line 84
is( 1, 0 );
err_ok( <<ERR );
# Failed test in $0 at line 84.
# got: '1'
# expected: '0'
ERR
}
--- NEW FILE: fail.t ---
#!perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use strict;
require Test::Simple::Catch;
my($out, $err) = Test::Simple::Catch::caught();
local $ENV{HARNESS_ACTIVE} = 0;
# 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::Simple;
Test::Simple->import(tests => 5);
#line 35
ok( 1, 'passing' );
ok( 2, 'passing still' );
ok( 3, 'still passing' );
ok( 0, 'oh no!' );
ok( 0, 'damnit' );
END {
My::Test::ok($$out eq <<OUT);
1..5
ok 1 - passing
ok 2 - passing still
ok 3 - still passing
not ok 4 - oh no!
not ok 5 - damnit
OUT
My::Test::ok($$err eq <<ERR);
# Failed test 'oh no!'
# in $0 at line 38.
# Failed test 'damnit'
# in $0 at line 39.
# Looks like you failed 2 tests of 5.
ERR
# Prevent Test::Simple from exiting with non zero
exit 0;
}
--- NEW FILE: useing.t ---
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Test::More tests => 5;
require_ok('Test::Builder');
require_ok("Test::More");
require_ok("Test::Simple");
{
package Foo;
use Test::More import => [qw(ok is can_ok)];
can_ok('Foo', qw(ok is can_ok));
ok( !Foo->can('like'), 'import working properly' );
}
--- NEW FILE: output.t ---
#!perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
chdir 't';
# Can't use Test.pm, that's a 5.005 thing.
print "1..4\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++;
return $test;
}
use TieOut;
use Test::Builder;
my $Test = Test::Builder->new();
my $result;
my $tmpfile = 'foo.tmp';
my $out = $Test->output($tmpfile);
END { unlink($tmpfile) }
ok( defined $out );
print $out "hi!\n";
close *$out;
undef $out;
open(IN, $tmpfile) or die $!;
chomp(my $line = <IN>);
close IN;
ok($line eq 'hi!');
open(FOO, ">>$tmpfile") or die $!;
$out = $Test->output(\*FOO);
$old = select *$out;
print "Hello!\n";
close *$out;
undef $out;
select $old;
open(IN, $tmpfile) or die $!;
my @lines = <IN>;
close IN;
ok($lines[1] =~ /Hello!/);
# Ensure stray newline in name escaping works.
$out = tie *FAKEOUT, 'TieOut';
$Test->output(\*FAKEOUT);
$Test->exported_to(__PACKAGE__);
$Test->no_ending(1);
$Test->plan(tests => 5);
$Test->ok(1, "ok");
$Test->ok(1, "ok\n");
$Test->ok(1, "ok, like\nok");
$Test->skip("wibble\nmoof");
$Test->todo_skip("todo\nskip\n");
my $output = $out->read;
ok( $output eq <<OUTPUT ) || print STDERR $output;
1..5
ok 1 - ok
ok 2 - ok
#
ok 3 - ok, like
# ok
ok 4 # skip wibble
# moof
not ok 5 # TODO & SKIP todo
# skip
#
OUTPUT
--- NEW FILE: simple.t ---
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use strict;
BEGIN { $| = 1; $^W = 1; }
use Test::Simple tests => 3;
ok(1, 'compile');
ok(1);
ok(1, 'foo');
--- NEW FILE: tbt_05faildiag.t ---
#!/usr/bin/perl
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Test::Builder::Tester tests => 5;
use Test::More;
# test_fail
test_out("not ok 1 - one");
test_fail(+1);
ok(0,"one");
test_out("not ok 2 - two");
test_fail(+2);
ok(0,"two");
test_test("test fail");
test_fail(+2);
test_out("not ok 1 - one");
ok(0,"one");
test_test("test_fail first");
# test_diag
use Test::Builder;
my $test = new Test::Builder;
test_diag("this is a test string","so is this");
$test->diag("this is a test string\n", "so is this\n");
test_test("test diag");
test_diag("this is a test string","so is this");
$test->diag("this is a test string\n");
$test->diag("so is this\n");
test_test("test diag multi line");
test_diag("this is a test string");
test_diag("so is this");
$test->diag("this is a test string\n");
$test->diag("so is this\n");
test_test("test diag multiple");
--- NEW FILE: require_ok.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use strict;
use Test::More tests => 8;
# Symbol and Class::Struct are both non-XS core modules back to 5.004.
# So they'll always be there.
require_ok("Symbol");
ok( $INC{'Symbol.pm'}, "require_ok MODULE" );
require_ok("Class/Struct.pm");
ok( $INC{'Class/Struct.pm'}, "require_ok FILE" );
# Its more trouble than its worth to try to create these filepaths to test
# through require_ok() so we cheat and use the internal logic.
ok !Test::More::_is_module_name('foo:bar');
ok !Test::More::_is_module_name('foo/bar.thing');
ok !Test::More::_is_module_name('Foo::Bar::');
ok Test::More::_is_module_name('V');
--- NEW FILE: is_deeply_fail.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use strict;
use Test::Builder;
require Test::Simple::Catch;
my($out, $err) = Test::Simple::Catch::caught();
Test::Builder->new->no_header(1);
Test::Builder->new->no_ending(1);
local $ENV{HARNESS_ACTIVE} = 0;
# Can't use Test.pm, that's a 5.005 thing.
package main;
my $TB = Test::Builder->create;
$TB->plan(tests => 73);
# Utility testing functions.
sub ok ($;$) {
return $TB->ok(@_);
}
sub is ($$;$) {
my($this, $that, $name) = @_;
my $ok = $TB->is_eq($$this, $that, $name);
$$this = '';
return $ok;
}
sub like ($$;$) {
my($this, $regex, $name) = @_;
$regex = "/$regex/" if !ref $regex and $regex !~ m{^/.*/$}s;
my $ok = $TB->like($$this, $regex, $name);
$$this = '';
return $ok;
}
require Test::More;
Test::More->import(tests => 11, import => ['is_deeply']);
my $Filename = quotemeta $0;
#line 68
ok !is_deeply('foo', 'bar', 'plain strings');
is( $out, "not ok 1 - plain strings\n", 'plain strings' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test 'plain strings'
# in $0 at line 68.
# got: 'foo'
# expected: 'bar'
ERR
#line 78
ok !is_deeply({}, [], 'different types');
is( $out, "not ok 2 - different types\n", 'different types' );
like( $err, <<ERR, ' right diagnostic' );
# Failed test 'different types'
# in $Filename at line 78.
# Structures begin differing at:
# \\\$got = HASH\\(0x[0-9a-f]+\\)
# \\\$expected = ARRAY\\(0x[0-9a-f]+\\)
ERR
#line 88
ok !is_deeply({ this => 42 }, { this => 43 }, 'hashes with different values');
is( $out, "not ok 3 - hashes with different values\n",
'hashes with different values' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test 'hashes with different values'
# in $0 at line 88.
# Structures begin differing at:
# \$got->{this} = '42'
# \$expected->{this} = '43'
ERR
#line 99
ok !is_deeply({ that => 42 }, { this => 42 }, 'hashes with different keys');
is( $out, "not ok 4 - hashes with different keys\n",
'hashes with different keys' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test 'hashes with different keys'
# in $0 at line 99.
# Structures begin differing at:
# \$got->{this} = Does not exist
# \$expected->{this} = '42'
ERR
#line 110
ok !is_deeply([1..9], [1..10], 'arrays of different length');
is( $out, "not ok 5 - arrays of different length\n",
'arrays of different length' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test 'arrays of different length'
# in $0 at line 110.
# Structures begin differing at:
# \$got->[9] = Does not exist
# \$expected->[9] = '10'
ERR
#line 121
ok !is_deeply([undef, undef], [undef], 'arrays of undefs' );
is( $out, "not ok 6 - arrays of undefs\n", 'arrays of undefs' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test 'arrays of undefs'
# in $0 at line 121.
# Structures begin differing at:
# \$got->[1] = undef
# \$expected->[1] = Does not exist
ERR
#line 131
ok !is_deeply({ foo => undef }, {}, 'hashes of undefs' );
is( $out, "not ok 7 - hashes of undefs\n", 'hashes of undefs' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test 'hashes of undefs'
# in $0 at line 131.
# Structures begin differing at:
# \$got->{foo} = undef
# \$expected->{foo} = Does not exist
ERR
#line 141
ok !is_deeply(\42, \23, 'scalar refs');
is( $out, "not ok 8 - scalar refs\n", 'scalar refs' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test 'scalar refs'
# in $0 at line 141.
# Structures begin differing at:
# \${ \$got} = '42'
# \${\$expected} = '23'
ERR
#line 151
ok !is_deeply([], \23, 'mixed scalar and array refs');
is( $out, "not ok 9 - mixed scalar and array refs\n",
'mixed scalar and array refs' );
like( $err, <<ERR, ' right diagnostic' );
# Failed test 'mixed scalar and array refs'
# in $Filename at line 151.
# Structures begin differing at:
# \\\$got = ARRAY\\(0x[0-9a-f]+\\)
# \\\$expected = SCALAR\\(0x[0-9a-f]+\\)
ERR
my($a1, $a2, $a3);
$a1 = \$a2; $a2 = \$a3;
$a3 = 42;
my($b1, $b2, $b3);
$b1 = \$b2; $b2 = \$b3;
$b3 = 23;
#line 173
ok !is_deeply($a1, $b1, 'deep scalar refs');
is( $out, "not ok 10 - deep scalar refs\n", 'deep scalar refs' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test 'deep scalar refs'
# in $0 at line 173.
# Structures begin differing at:
# \${\${ \$got}} = '42'
# \${\${\$expected}} = '23'
ERR
# I don't know how to properly display this structure.
# $a2 = { foo => \$a3 };
# $b2 = { foo => \$b3 };
# is_deeply([$a1], [$b1], 'deep mixed scalar refs');
my $foo = {
this => [1..10],
that => { up => "down", left => "right" },
};
my $bar = {
this => [1..10],
that => { up => "down", left => "right", foo => 42 },
};
#line 198
ok !is_deeply( $foo, $bar, 'deep structures' );
ok( @Test::More::Data_Stack == 0, '@Data_Stack not holding onto things' );
is( $out, "not ok 11 - deep structures\n", 'deep structures' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test 'deep structures'
# in $0 at line 198.
# Structures begin differing at:
# \$got->{that}{foo} = Does not exist
# \$expected->{that}{foo} = '42'
ERR
#line 221
my @tests = ([],
[qw(42)],
[qw(42 23), qw(42 23)]
);
foreach my $test (@tests) {
my $num_args = @$test;
my $warning;
local $SIG{__WARN__} = sub { $warning .= join '', @_; };
ok !is_deeply(@$test);
like \$warning,
"/^is_deeply\\(\\) takes two or three args, you gave $num_args\.\n/";
}
#line 240
# [rt.cpan.org 6837]
ok !is_deeply([{Foo => undef}],[{Foo => ""}]), 'undef != ""';
ok( @Test::More::Data_Stack == 0, '@Data_Stack not holding onto things' );
#line 258
# [rt.cpan.org 7031]
my $a = [];
ok !is_deeply($a, $a.''), "don't compare refs like strings";
ok !is_deeply([$a], [$a.'']), " even deep inside";
#line 265
# [rt.cpan.org 7030]
ok !is_deeply( {}, {key => []} ), '[] could match non-existent values';
ok !is_deeply( [], [[]] );
#line 273
$$err = $$out = '';
ok !is_deeply( [\'a', 'b'], [\'a', 'c'] );
is( $out, "not ok 20\n", 'scalar refs in an array' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test in $0 at line 274.
# Structures begin differing at:
# \$got->[1] = 'b'
# \$expected->[1] = 'c'
ERR
#line 285
my $ref = \23;
ok !is_deeply( 23, $ref );
is( $out, "not ok 21\n", 'scalar vs ref' );
is( $err, <<ERR, ' right diagnostic');
# Failed test in $0 at line 286.
# Structures begin differing at:
# \$got = '23'
# \$expected = $ref
ERR
#line 296
ok !is_deeply( $ref, 23 );
is( $out, "not ok 22\n", 'ref vs scalar' );
is( $err, <<ERR, ' right diagnostic');
# Failed test in $0 at line 296.
# Structures begin differing at:
# \$got = $ref
# \$expected = '23'
ERR
#line 306
ok !is_deeply( undef, [] );
is( $out, "not ok 23\n", 'is_deeply and undef [RT 9441]' );
like( $err, <<ERR, ' right diagnostic' );
# Failed test in $Filename at line 306\\.
# Structures begin differing at:
# \\\$got = undef
# \\\$expected = ARRAY\\(0x[0-9a-f]+\\)
ERR
# rt.cpan.org 8865
{
my $array = [];
my $hash = {};
#line 321
ok !is_deeply( $array, $hash );
is( $out, "not ok 24\n", 'is_deeply and different reference types' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test in $0 at line 321.
# Structures begin differing at:
# \$got = $array
# \$expected = $hash
ERR
#line 332
ok !is_deeply( [$array], [$hash] );
is( $out, "not ok 25\n", 'nested different ref types' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test in $0 at line 332.
# Structures begin differing at:
# \$got->[0] = $array
# \$expected->[0] = $hash
ERR
if( eval { require overload } ) {
my $foo = bless [], "Foo";
my $bar = bless {}, "Bar";
{
package Bar;
"overload"->import(q[""] => sub { "wibble" });
}
#line 353
ok !is_deeply( [$foo], [$bar] );
is( $out, "not ok 26\n", 'string overloaded refs respected in diag' );
is( $err, <<ERR, ' right diagnostic' );
# Failed test in $0 at line 353.
# Structures begin differing at:
# \$got->[0] = $foo
# \$expected->[0] = 'wibble'
ERR
}
else {
$TB->skip("Needs overload.pm") for 1..3;
}
}
# rt.cpan.org 14746
{
# line 349
ok !is_deeply( sub {"foo"}, sub {"bar"} ), 'function refs';
is( $out, "not ok 27\n" );
like( $err, <<ERR, ' right diagnostic' );
# Failed test in $Filename at line 349.
# Structures begin differing at:
# \\\$got = CODE\\(0x[0-9a-f]+\\)
# \\\$expected = CODE\\(0x[0-9a-f]+\\)
ERR
use Symbol;
my $glob1 = gensym;
my $glob2 = gensym;
#line 357
ok !is_deeply( $glob1, $glob2 ), 'typeglobs';
is( $out, "not ok 28\n" );
like( $err, <<ERR, ' right diagnostic' );
# Failed test in $0 at line 357.
# Structures begin differing at:
# \\\$got = GLOB\\(0x[0-9a-f]+\\)
# \\\$expected = GLOB\\(0x[0-9a-f]+\\)
ERR
}
--- NEW FILE: Builder.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Test::Builder;
my $Test = Test::Builder->new;
$Test->plan( tests => 7 );
my $default_lvl = $Test->level;
$Test->level(0);
$Test->ok( 1, 'compiled and new()' );
$Test->ok( $default_lvl == 1, 'level()' );
$Test->is_eq('foo', 'foo', 'is_eq');
$Test->is_num('23.0', '23', 'is_num');
$Test->is_num( $Test->current_test, 4, 'current_test() get' );
my $test_num = $Test->current_test + 1;
$Test->current_test( $test_num );
print "ok $test_num - current_test() set\n";
$Test->ok( 1, 'counter still good' );
--- NEW FILE: plan_no_plan.t ---
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Test::More;
BEGIN {
if( !$ENV{HARNESS_ACTIVE} && $ENV{PERL_CORE} ) {
plan skip_all => "Won't work with t/TEST";
}
}
plan 'no_plan';
pass('Just testing');
ok(1, 'Testing again');
{
my $warning = '';
local $SIG{__WARN__} = sub { $warning = join "", @_ };
SKIP: {
skip 'Just testing skip with no_plan';
fail("So very failed");
}
is( $warning, '', 'skip with no "how_many" ok with no_plan' );
$warning = '';
TODO: {
todo_skip "Just testing todo_skip";
fail("Just testing todo");
die "todo_skip should prevent this";
pass("Again");
}
is( $warning, '', 'skip with no "how_many" ok with no_plan' );
}
--- NEW FILE: has_plan.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib');
}
}
use strict;
use Test::Builder;
my $unplanned;
BEGIN {
$unplanned = 'oops';
$unplanned = Test::Builder->new->has_plan;
};
use Test::More tests => 2;
is($unplanned, undef, 'no plan yet defined');
is(Test::Builder->new->has_plan, 2, 'has fixed plan');
--- NEW FILE: tbt_06errormess.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Test::More tests => 8;
use Symbol;
use Test::Builder;
use Test::Builder::Tester;
use strict;
# argh! now we need to test the thing we're testing. Basically we need
# to pretty much reimplement the whole code again. This is very
# annoying but can't be avoided. And onwards with the cut and paste
# My brain is melting. My brain is melting. ETOOMANYLAYERSOFTESTING
# create some private file handles
my $output_handle = gensym;
my $error_handle = gensym;
# and tie them to this package
my $out = tie *$output_handle, "Test::Tester::Tie", "STDOUT";
my $err = tie *$error_handle, "Test::Tester::Tie", "STDERR";
# ooooh, use the test suite
my $t = Test::Builder->new;
# remember the testing outputs
my $original_output_handle;
my $original_failure_handle;
my $original_todo_handle;
my $original_harness_env;
my $testing_num;
sub start_testing
{
# remember what the handles were set to
$original_output_handle = $t->output();
$original_failure_handle = $t->failure_output();
$original_todo_handle = $t->todo_output();
$original_harness_env = $ENV{HARNESS_ACTIVE};
# switch out to our own handles
$t->output($output_handle);
$t->failure_output($error_handle);
$t->todo_output($error_handle);
$ENV{HARNESS_ACTIVE} = 0;
# clear the expected list
$out->reset();
$err->reset();
# remeber that we're testing
$testing_num = $t->current_test;
$t->current_test(0);
}
# each test test is actually two tests. This is bad and wrong
# but makes blood come out of my ears if I don't at least simplify
# it a little this way
sub my_test_test
{
my $text = shift;
local $^W = 0;
# reset the outputs
$t->output($original_output_handle);
$t->failure_output($original_failure_handle);
$t->todo_output($original_todo_handle);
$ENV{HARNESS_ACTIVE} = $original_harness_env;
# reset the number of tests
$t->current_test($testing_num);
# check we got the same values
my $got;
my $wanted;
# stdout
$t->ok($out->check, "STDOUT $text");
# stderr
$t->ok($err->check, "STDERR $text");
}
####################################################################
# Meta meta tests
####################################################################
# this is a quick test to check the hack that I've just implemented
# actually does a cut down version of Test::Builder::Tester
start_testing();
$out->expect("ok 1 - foo");
pass("foo");
my_test_test("basic meta meta test");
start_testing();
$out->expect("not ok 1 - foo");
$err->expect("# Failed test ($0 at line ".line_num(+1).")");
fail("foo");
my_test_test("basic meta meta test 2");
start_testing();
$out->expect("ok 1 - bar");
test_out("ok 1 - foo");
pass("foo");
test_test("bar");
my_test_test("meta meta test with tbt");
start_testing();
$out->expect("ok 1 - bar");
test_out("not ok 1 - foo");
test_err("# Failed test ($0 at line ".line_num(+1).")");
fail("foo");
test_test("bar");
my_test_test("meta meta test with tbt2 ");
####################################################################
--- NEW FILE: fail-like.t ---
# 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 # Skipped Test requires qr//\n";
exit(0);
}
}
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.
use strict;
# Can't use Test.pm, that's a 5.005 thing.
package My::Test;
# This has to be a require or else the END block below runs before
# Test::Builder's own and the ending diagnostics don't come out right.
require Test::Builder;
my $TB = Test::Builder->create;
$TB->plan(tests => 2);
require Test::Simple::Catch;
my($out, $err) = Test::Simple::Catch::caught();
local $ENV{HARNESS_ACTIVE} = 0;
package main;
require Test::More;
Test::More->import(tests => 1);
eval q{ like( "foo", qr/that/, 'is foo like that' ); };
END {
$TB->is_eq($$out, <<OUT, 'failing output');
1..1
not ok 1 - is foo like that
OUT
my $err_re = <<ERR;
# Failed test 'is foo like that'
# in .* at line 1\.
# 'foo'
# doesn't match '\\(\\?-xism:that\\)'
# Looks like you failed 1 test of 1\\.
ERR
$TB->like($$err, qr/^$err_re$/, 'failing errors');
exit(0);
}
--- NEW FILE: no_header.t ---
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Test::Builder;
# STDOUT must be unbuffered else our prints might come out after
# Test::More's.
$| = 1;
BEGIN {
Test::Builder->new->no_header(1);
}
use Test::More tests => 1;
print "1..1\n";
pass;
--- NEW FILE: buffer.t ---
#!/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";
}
--- NEW FILE: 00test_harness_check.t ---
#!/usr/bin/perl -w
# A test to make sure the new Test::Harness was installed properly.
use Test::More;
plan tests => 1;
my $TH_Version = 2.03;
require Test::Harness;
unless( cmp_ok( $Test::Harness::VERSION, '>', $TH_Version, "T::H version" ) ) {
diag <<INSTRUCTIONS;
Test::Simple/More/Builder has features which depend on a version of
Test::Harness greater than $TH_Version. You have $Test::Harness::VERSION.
Please install a new version from CPAN.
If you've already tried to upgrade Test::Harness and still get this
message, the new version may be "shadowed" by the old. Check the
output of Test::Harness's "make install" for "## Differing version"
messages. You can delete the old version by running
"make install UNINST=1".
INSTRUCTIONS
}
--- NEW FILE: missing.t ---
BEGIN {
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 has to be a require or else the END block below runs before
# Test::Builder's own and the ending diagnostics don't come out right.
require Test::Builder;
my $TB = Test::Builder->create;
$TB->plan(tests => 2);
sub is { $TB->is_eq(@_) }
package main;
require Test::Simple;
require Test::Simple::Catch;
my($out, $err) = Test::Simple::Catch::caught();
local $ENV{HARNESS_ACTIVE} = 0;
Test::Simple->import(tests => 5);
#line 30
ok(1, 'Foo');
ok(0, 'Bar');
END {
My::Test::is($$out, <<OUT);
1..5
ok 1 - Foo
not ok 2 - Bar
OUT
My::Test::is($$err, <<ERR);
# Failed test 'Bar'
# in $0 at line 31.
# Looks like you planned 5 tests but only ran 2.
# Looks like you failed 1 test of 2 run.
ERR
exit 0;
}
--- NEW FILE: skipall.t ---
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
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) = @_;
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;
require Test::Simple::Catch;
my($out, $err) = Test::Simple::Catch::caught();
Test::More->import('skip_all');
END {
My::Test::ok($$out eq "1..0\n");
My::Test::ok($$err eq "");
}
--- NEW FILE: tbt_02fhrestore.t ---
#!/usr/bin/perl
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Test::Builder::Tester tests => 4;
use Test::More;
use Symbol;
# create temporary file handles that still point indirectly
# to the right place
my $orig_o = gensym;
my $orig_t = gensym;
my $orig_f = gensym;
tie *$orig_o, "My::Passthru", \*STDOUT;
tie *$orig_t, "My::Passthru", \*STDERR;
tie *$orig_f, "My::Passthru", \*STDERR;
# redirect the file handles to somewhere else for a mo
use Test::Builder;
my $t = Test::Builder->new();
$t->output($orig_o);
$t->failure_output($orig_f);
$t->todo_output($orig_t);
# run a test
test_out("ok 1 - tested");
ok(1,"tested");
test_test("standard test okay");
# now check that they were restored okay
ok($orig_o == $t->output(), "output file reconnected");
ok($orig_t == $t->todo_output(), "todo output file reconnected");
ok($orig_f == $t->failure_output(), "failure output file reconnected");
#####################################################################
package My::Passthru;
sub PRINT {
my $self = shift;
my $handle = $self->[0];
print $handle @_;
}
sub TIEHANDLE {
my $class = shift;
my $self = [shift()];
return bless $self, $class;
}
sub READ {}
sub READLINE {}
sub GETC {}
sub FILENO {}
--- NEW FILE: use_ok.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use Test::More tests => 13;
# Using Symbol because it's core and exports lots of stuff.
{
package Foo::one;
::use_ok("Symbol");
::ok( defined &gensym, 'use_ok() no args exports defaults' );
}
{
package Foo::two;
::use_ok("Symbol", qw(qualify));
::ok( !defined &gensym, ' one arg, defaults overriden' );
::ok( defined &qualify, ' right function exported' );
}
{
package Foo::three;
::use_ok("Symbol", qw(gensym ungensym));
::ok( defined &gensym && defined &ungensym, ' multiple args' );
}
{
package Foo::four;
my $warn; local $SIG{__WARN__} = sub { $warn .= shift; };
::use_ok("constant", qw(foo bar));
::ok( defined &foo, 'constant' );
::is( $warn, undef, 'no warning');
}
{
package Foo::five;
::use_ok("Symbol", 1.02);
}
{
package Foo::six;
::use_ok("NoExporter", 1.02);
}
{
package Foo::seven;
local $SIG{__WARN__} = sub {
# Old perls will warn on X.YY_ZZ style versions. Not our problem
warn @_ unless $_[0] =~ /^Argument "\d+\.\d+_\d+" isn't numeric/;
};
::use_ok("Test::More", 0.47);
}
--- NEW FILE: has_plan2.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Test::More;
BEGIN {
if( !$ENV{HARNESS_ACTIVE} && $ENV{PERL_CORE} ) {
plan skip_all => "Won't work with t/TEST";
}
}
use strict;
use Test::Builder;
plan 'no_plan';
is(Test::Builder->new->has_plan, 'no_plan', 'has no_plan');
--- NEW FILE: todo.t ---
#!perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Test::More;
plan tests => 18;
$Why = 'Just testing the todo interface.';
my $is_todo;
TODO: {
local $TODO = $Why;
fail("Expected failure");
fail("Another expected failure");
$is_todo = Test::More->builder->todo;
}
pass("This is not todo");
ok( $is_todo, 'TB->todo' );
TODO: {
local $TODO = $Why;
fail("Yet another failure");
}
pass("This is still not todo");
TODO: {
local $TODO = "testing that error messages don't leak out of todo";
ok( 'this' eq 'that', 'ok' );
like( 'this', '/that/', 'like' );
is( 'this', 'that', 'is' );
isnt( 'this', 'this', 'isnt' );
can_ok('Fooble', 'yarble');
isa_ok('Fooble', 'yarble');
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");
}
{
my $warning;
local $SIG{__WARN__} = sub { $warning = join "", @_ };
TODO: {
# perl gets the line number a little wrong on the first
# statement inside a block.
1 == 1;
#line 82
todo_skip "Just testing todo_skip";
fail("So very failed");
}
is( $warning, "todo_skip() needs to know \$how_many tests are in the ".
"block at $0 line 82\n",
'todo_skip without $how_many warning' );
}
--- NEW FILE: plan_shouldnt_import.t ---
#!/usr/bin/perl -w
# plan() used to export functions by mistake [rt.cpan.org 8385]
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Test::More ();
Test::More::plan(tests => 1);
Test::More::ok( !__PACKAGE__->can('ok'), 'plan should not export' );
--- NEW FILE: exit.t ---
#!/usr/bin/perl -w
# 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;
}
if( $^O eq 'VMS' && $] <= 5.00503 ) {
print "1..0 # Skip test will hang on older VMS perls\n";
exit 0;
}
if( $^O eq 'MacOS' ) {
print "1..0 # Skip exit status broken on Mac OS\n";
exit 0;
}
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;
my $IsVMS = $^O eq 'VMS';
print "# Ahh! I see you're running VMS.\n" if $IsVMS;
my %Tests = (
# Everyone Else VMS
'success.plx' => [0, 0],
'one_fail.plx' => [1, 4],
'two_fail.plx' => [2, 4],
'five_fail.plx' => [5, 4],
'extras.plx' => [2, 4],
'too_few.plx' => [255, 4],
'too_few_fail.plx' => [2, 4],
'death.plx' => [255, 4],
'last_minute_death.plx' => [255, 4],
'pre_plan_death.plx' => ['not zero', 'not zero'],
'death_in_eval.plx' => [0, 0],
'require.plx' => [0, 0],
'exit.plx' => [1, 4],
);
print "1..".keys(%Tests)."\n";
eval { require POSIX; &POSIX::WEXITSTATUS(0) };
if( $@ ) {
*exitstatus = sub { $_[0] >> 8 };
}
else {
*exitstatus = sub { POSIX::WEXITSTATUS($_[0]) }
}
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{$Perl -"I../blib/lib" -"I../lib" -"I../t/lib" $file});
my $actual_exit = exitstatus($wait_stat);
if( $exit_code eq 'not zero' ) {
My::Test::ok( $actual_exit != 0,
"$test_name exited with $actual_exit ".
"(expected $exit_code)");
}
else {
My::Test::ok( $actual_exit == $exit_code,
"$test_name exited with $actual_exit ".
"(expected $exit_code)");
}
}
--- NEW FILE: maybe_regex.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use strict;
use Test::More tests => 13;
use Test::Builder;
my $Test = Test::Builder->new;
SKIP: {
skip "qr// added in 5.005", 3 if $] < 5.005;
# 5.004 can't even see qr// or it pukes in compile.
eval q{
my $r = $Test->maybe_regex(qr/^FOO$/i);
ok(defined $r, 'qr// detected');
ok(('foo' =~ /$r/), 'qr// good match');
ok(('bar' !~ /$r/), 'qr// bad match');
};
die $@ if $@;
}
{
my $r = $Test->maybe_regex('/^BAR$/i');
ok(defined $r, '"//" detected');
ok(('bar' =~ m/$r/), '"//" good match');
ok(('foo' !~ m/$r/), '"//" bad match');
};
{
my $r = $Test->maybe_regex('not a regex');
ok(!defined $r, 'non-regex detected');
};
{
my $r = $Test->maybe_regex('/0/');
ok(defined $r, 'non-regex detected');
ok(('f00' =~ m/$r/), '"//" good match');
ok(('b4r' !~ m/$r/), '"//" bad match');
};
{
my $r = $Test->maybe_regex('m,foo,i');
ok(defined $r, 'm,, detected');
ok(('fOO' =~ m/$r/), '"//" good match');
ok(('bar' !~ m/$r/), '"//" bad match');
};
--- NEW FILE: import.t ---
BEGIN {
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));
ok( !__PACKAGE__->can('fail'), 'fail() not exported' );
--- NEW FILE: bail_out.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
my $Exit_Code;
BEGIN {
*CORE::GLOBAL::exit = sub { $Exit_Code = shift; };
}
use Test::Builder;
use Test::More;
use TieOut;
my $output = tie *FAKEOUT, 'TieOut';
my $TB = Test::More->builder;
$TB->output(\*FAKEOUT);
my $Test = Test::Builder->create;
$Test->level(0);
if( $] >= 5.005 ) {
$Test->plan(tests => 2);
}
else {
$Test->plan(skip_all =>
'CORE::GLOBAL::exit, introduced in 5.005, is needed for testing');
}
plan tests => 4;
BAIL_OUT("ROCKS FALL! EVERYONE DIES!");
$Test->is_eq( $output->read, <<'OUT' );
1..4
Bail out! ROCKS FALL! EVERYONE DIES!
OUT
$Test->is_eq( $Exit_Code, 255 );
--- NEW FILE: tbt_07args.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Test::More tests => 18;
use Symbol;
use Test::Builder;
use Test::Builder::Tester;
use strict;
# argh! now we need to test the thing we're testing. Basically we need
# to pretty much reimplement the whole code again. This is very
# annoying but can't be avoided. And onwards with the cut and paste
# My brain is melting. My brain is melting. ETOOMANYLAYERSOFTESTING
# create some private file handles
my $output_handle = gensym;
my $error_handle = gensym;
# and tie them to this package
my $out = tie *$output_handle, "Test::Tester::Tie", "STDOUT";
my $err = tie *$error_handle, "Test::Tester::Tie", "STDERR";
# ooooh, use the test suite
my $t = Test::Builder->new;
# remember the testing outputs
my $original_output_handle;
my $original_failure_handle;
my $original_todo_handle;
my $testing_num;
my $original_harness_env;
sub start_testing
{
# remember what the handles were set to
$original_output_handle = $t->output();
$original_failure_handle = $t->failure_output();
$original_todo_handle = $t->todo_output();
$original_harness_env = $ENV{HARNESS_ACTIVE};
# switch out to our own handles
$t->output($output_handle);
$t->failure_output($error_handle);
$t->todo_output($error_handle);
$ENV{HARNESS_ACTIVE} = 0;
# clear the expected list
$out->reset();
$err->reset();
# remeber that we're testing
$testing_num = $t->current_test;
$t->current_test(0);
}
# each test test is actually two tests. This is bad and wrong
# but makes blood come out of my ears if I don't at least simplify
# it a little this way
sub my_test_test
{
my $text = shift;
local $^W = 0;
# reset the outputs
$t->output($original_output_handle);
$t->failure_output($original_failure_handle);
$t->todo_output($original_todo_handle);
$ENV{HARNESS_ACTIVE} = $original_harness_env;
# reset the number of tests
$t->current_test($testing_num);
# check we got the same values
my $got;
my $wanted;
# stdout
$t->ok($out->check, "STDOUT $text");
# stderr
$t->ok($err->check, "STDERR $text");
}
####################################################################
# Meta meta tests
####################################################################
# this is a quick test to check the hack that I've just implemented
# actually does a cut down version of Test::Builder::Tester
start_testing();
$out->expect("ok 1 - foo");
pass("foo");
my_test_test("basic meta meta test");
start_testing();
$out->expect("not ok 1 - foo");
$err->expect("# Failed test ($0 at line ".line_num(+1).")");
fail("foo");
my_test_test("basic meta meta test 2");
start_testing();
$out->expect("ok 1 - bar");
test_out("ok 1 - foo");
pass("foo");
test_test("bar");
my_test_test("meta meta test with tbt");
start_testing();
$out->expect("ok 1 - bar");
test_out("not ok 1 - foo");
test_err("# Failed test ($0 at line ".line_num(+1).")");
fail("foo");
test_test("bar");
my_test_test("meta meta test with tbt2 ");
####################################################################
# Actual meta tests
####################################################################
# set up the outer wrapper again
start_testing();
$out->expect("ok 1 - bar");
# set up what the inner wrapper expects
test_out("ok 1 - foo");
# the actual test function that we are testing
ok("1","foo");
# test the name
test_test(name => "bar");
# check that passed
my_test_test("meta test name");
####################################################################
# set up the outer wrapper again
start_testing();
$out->expect("ok 1 - bar");
# set up what the inner wrapper expects
test_out("ok 1 - foo");
# the actual test function that we are testing
ok("1","foo");
# test the name
test_test(title => "bar");
# check that passed
my_test_test("meta test title");
####################################################################
# set up the outer wrapper again
start_testing();
$out->expect("ok 1 - bar");
# set up what the inner wrapper expects
test_out("ok 1 - foo");
# the actual test function that we are testing
ok("1","foo");
# test the name
test_test(label => "bar");
# check that passed
my_test_test("meta test title");
####################################################################
# set up the outer wrapper again
start_testing();
$out->expect("ok 1 - bar");
# set up what the inner wrapper expects
test_out("not ok 1 - foo this is wrong");
test_fail(+3);
# the actual test function that we are testing
ok("0","foo");
# test that we got what we expect, ignoring our is wrong
test_test(skip_out => 1, name => "bar");
# check that that passed
my_test_test("meta test skip_out");
####################################################################
# set up the outer wrapper again
start_testing();
$out->expect("ok 1 - bar");
# set up what the inner wrapper expects
test_out("not ok 1 - foo");
test_err("this is wrong");
# the actual test function that we are testing
ok("0","foo");
# test that we got what we expect, ignoring err is wrong
test_test(skip_err => 1, name => "bar");
# diagnostics failing out
# check that that passed
my_test_test("meta test skip_err");
####################################################################
--- NEW FILE: fork.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Test::More;
use Config;
my $Can_Fork = $Config{d_fork} ||
(($^O eq 'MSWin32' || $^O eq 'NetWare') and
$Config{useithreads} and
$Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/
);
if( !$Can_Fork ) {
plan skip_all => "This system cannot fork";
}
else {
plan tests => 1;
}
if( fork ) { # parent
pass("Only the parent should process the ending, not the child");
}
else {
exit; # child
}
--- NEW FILE: plan_is_noplan.t ---
BEGIN {
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;
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::Simple;
require Test::Simple::Catch;
my($out, $err) = Test::Simple::Catch::caught();
Test::Simple->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::Simple from exiting with non zero
exit 0;
}
--- NEW FILE: bad_plan.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
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++;
return $test;
}
use Test::Builder;
my $Test = Test::Builder->new;
print "1..2\n";
eval { $Test->plan(7); };
ok( $@ =~ /^plan\(\) doesn't understand 7/, 'bad plan()' ) ||
print STDERR "# $@";
eval { $Test->plan(wibble => 7); };
ok( $@ =~ /^plan\(\) doesn't understand wibble 7/, 'bad plan()' ) ||
print STDERR "# $@";
--- NEW FILE: no_plan.t ---
BEGIN {
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;
print "1..12\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::Simple;
require Test::Simple::Catch;
my($out, $err) = Test::Simple::Catch::caught();
eval {
Test::Simple->import;
};
My::Test::ok($$out eq '');
My::Test::ok($$err eq '');
My::Test::ok($@ eq '');
eval {
Test::Simple->import(tests => undef);
};
My::Test::ok($$out eq '');
My::Test::ok($$err eq '');
My::Test::ok($@ =~ /Got an undefined number of tests/);
eval {
Test::Simple->import(tests => 0);
};
My::Test::ok($$out eq '');
My::Test::ok($$err eq '');
My::Test::ok($@ =~ /You said to run 0 tests!/);
eval {
Test::Simple::ok(1);
};
My::Test::ok( $@ =~ /You tried to run a test without a plan!/);
END {
My::Test::ok($$out eq '');
My::Test::ok($$err eq "");
# Prevent Test::Simple from exiting with non zero.
exit 0;
}
--- NEW FILE: More.t ---
#!perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Test::More tests => 51;
# 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');
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');
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' );
my @foo = qw(foo bar baz);
unlike(@foo, '/foo/');
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');
# can_ok() & isa_ok should call can() & isa() on the given object, not
# just class, in case of custom can()
{
local *Foo::can;
local *Foo::isa;
*Foo::can = sub { $_[0]->[0] };
*Foo::isa = sub { $_[0]->[0] };
my $foo = bless([0], 'Foo');
ok( ! $foo->can('bar') );
ok( ! $foo->isa('bar') );
$foo->[0] = 1;
can_ok( $foo, 'blah');
isa_ok( $foo, 'blah');
}
pass('pass() passed');
ok( eq_array([qw(this that whatever)], [qw(this that whatever)]),
'eq_array with simple arrays' );
is @Test::More::Data_Stack, 0, '@Data_Stack not holding onto things';
ok( eq_hash({ foo => 42, bar => 23 }, {bar => 23, foo => 42}),
'eq_hash with simple hashes' );
is @Test::More::Data_Stack, 0;
ok( eq_set([qw(this that whatever)], [qw(that whatever this)]),
'eq_set with simple sets' );
is @Test::More::Data_Stack, 0;
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)],
);
is_deeply( \@complex_array1, \@complex_array2, 'is_deeply with arrays' );
ok( eq_array(\@complex_array1, \@complex_array2),
'eq_array with complicated arrays' );
ok( eq_set(\@complex_array1, \@complex_array2),
'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' );
is @Test::More::Data_Stack, 0;
ok( !eq_set(\@array1, \@array2),
'eq_set with slightly different complicated arrays' );
is @Test::More::Data_Stack, 0;
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 },
);
is_deeply( \%hash1, \%hash2, 'is_deeply with complicated hashes' );
ok( eq_hash(\%hash1, \%hash2), 'eq_hash with complicated hashes');
%hash1 = ( foo => 23,
bar => [qw(this that whatever)],
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' );
is @Test::More::Data_Stack, 0;
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' );
my $sub = sub {};
is_deeply( $sub, $sub, 'the same function ref' );
use Symbol;
my $glob = gensym;
is_deeply( $glob, $glob, 'the same glob' );
is_deeply( { foo => $sub, bar => [1, $glob] },
{ foo => $sub, bar => [1, $glob] }
);
# These two tests must remain at the end.
is( $@, $Err, '$@ untouched' );
cmp_ok( $!, '==', $Errno, '$! untouched' );
--- NEW FILE: tbt_04line_num.t ---
#!/usr/bin/perl
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Test::More tests => 3;
use Test::Builder::Tester;
is(line_num(),13,"normal line num");
is(line_num(-1),13,"line number minus one");
is(line_num(+2),17,"line number plus two");
--- NEW FILE: plan.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Test::More;
plan tests => 4;
eval { plan tests => 4 };
like( $@, '/^You tried to plan twice!/', 'disallow double plan' );
eval { plan 'no_plan' };
like( $@, '/^You tried to plan twice!/', 'disallow chaning plan' );
pass('Just testing plan()');
pass('Testing it some more');
--- NEW FILE: undef.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use strict;
use Test::More tests => 18;
use TieOut;
BEGIN { $^W = 1; }
my $warnings = '';
local $SIG{__WARN__} = sub { $warnings .= join '', @_ };
my $TB = Test::Builder->new;
sub no_warnings {
$TB->is_eq($warnings, '', ' no warnings');
$warnings = '';
}
sub warnings_is {
$TB->is_eq($warnings, $_[0]);
$warnings = '';
}
sub warnings_like {
$TB->like($warnings, "/$_[0]/");
$warnings = '';
}
my $Filename = quotemeta $0;
is( undef, undef, 'undef is undef');
no_warnings;
isnt( undef, 'foo', 'undef isnt foo');
no_warnings;
isnt( undef, '', 'undef isnt an empty string' );
isnt( undef, 0, 'undef isnt zero' );
#line 45
like( undef, '/.*/', 'undef is like anything' );
warnings_like("Use of uninitialized value.* at $Filename line 45\\.\n");
eq_array( [undef, undef], [undef, 23] );
no_warnings;
eq_hash ( { foo => undef, bar => undef },
{ foo => undef, bar => 23 } );
no_warnings;
eq_set ( [undef, undef, 12], [29, undef, undef] );
no_warnings;
eq_hash ( { foo => undef, bar => { baz => undef, moo => 23 } },
{ foo => undef, bar => { baz => undef, moo => 23 } } );
no_warnings;
#line 64
cmp_ok( undef, '<=', 2, ' undef <= 2' );
warnings_like("Use of uninitialized value.* at $Filename line 64\\.\n");
my $tb = Test::More->builder;
use TieOut;
my $caught = tie *CATCH, 'TieOut';
my $old_fail = $tb->failure_output;
$tb->failure_output(\*CATCH);
diag(undef);
$tb->failure_output($old_fail);
is( $caught->read, "# undef\n" );
no_warnings;
$tb->maybe_regex(undef);
is( $caught->read, '' );
no_warnings;
--- NEW FILE: skip.t ---
#!perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Test::More tests => 15;
# If we skip with the same name, Test::Harness will report it back and
# we won't get lots of false bug reports.
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");
}
{
my $warning;
local $SIG{__WARN__} = sub { $warning = join "", @_ };
SKIP: {
# perl gets the line number a little wrong on the first
# statement inside a block.
1 == 1;
#line 56
skip $Why;
fail("So very failed");
}
is( $warning, "skip() needs to know \$how_many tests are in the ".
"block at $0 line 56\n",
'skip without $how_many warning' );
}
SKIP: {
skip "Not skipping here.", 4 if 0;
pass("This is supposed to run");
# Testing out nested skips.
SKIP: {
skip $Why, 2;
fail("AHHH!");
fail("You're a failure");
}
pass("This is supposed to run, too");
}
--- NEW FILE: overload.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use strict;
use Test::More;
BEGIN {
if( !eval "require overload" ) {
plan skip_all => "needs overload.pm";
}
else {
plan tests => 13;
}
}
package Overloaded;
use overload
q{""} => sub { $_[0]->{string} },
q{0+} => sub { $_[0]->{num} };
sub new {
my $class = shift;
bless { string => shift, num => shift }, $class;
}
package main;
my $obj = Overloaded->new('foo', 42);
isa_ok $obj, 'Overloaded';
is $obj, 'foo', 'is() with string overloading';
cmp_ok $obj, 'eq', 'foo', 'cmp_ok() ...';
cmp_ok $obj, '==', 42, 'cmp_ok() with number overloading';
is_deeply [$obj], ['foo'], 'is_deeply with string overloading';
ok eq_array([$obj], ['foo']), 'eq_array ...';
ok eq_hash({foo => $obj}, {foo => 'foo'}), 'eq_hash ...';
# rt.cpan.org 13506
is_deeply $obj, 'foo', 'is_deeply with string overloading at the top';
Test::More->builder->is_num($obj, 42);
Test::More->builder->is_eq ($obj, "foo");
{
# rt.cpan.org 14675
package TestPackage;
use overload q{""} => sub { ::fail("This should not be called") };
package Foo;
::is_deeply(['TestPackage'], ['TestPackage']);
::is_deeply({'TestPackage' => 'TestPackage'},
{'TestPackage' => 'TestPackage'});
::is_deeply('TestPackage', 'TestPackage');
}
--- NEW FILE: filehandles.t ---
#!perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Test::More tests => 1;
tie *STDOUT, "Dev::Null" or die $!;
print "not ok 1\n"; # this should not print.
pass 'STDOUT can be mucked with';
package Dev::Null;
sub TIEHANDLE { bless {} }
sub PRINT { 1 }
--- NEW FILE: extra_one.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use strict;
require Test::Simple::Catch;
my($out, $err) = Test::Simple::Catch::caught();
# Can't use Test.pm, that's a 5.005 thing.
package My::Test;
# This has to be a require or else the END block below runs before
# Test::Builder's own and the ending diagnostics don't come out right.
require Test::Builder;
my $TB = Test::Builder->create;
$TB->plan(tests => 2);
sub is { $TB->is_eq(@_) }
package main;
require Test::Simple;
Test::Simple->import(tests => 1);
ok(1);
ok(1);
ok(1);
END {
My::Test::is($$out, <<OUT);
1..1
ok 1
ok 2
ok 3
OUT
My::Test::is($$err, <<ERR);
# Looks like you planned 1 test but ran 2 extra.
ERR
# Prevent Test::Simple from existing with non-zero
exit 0;
}
--- NEW FILE: reset.t ---
#!/usr/bin/perl -w
# Test Test::Builder->reset;
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
chdir 't';
use Test::Builder;
my $tb = Test::Builder->new;
$tb->plan(tests => 14);
$tb->level(0);
# Alter the state of Test::Builder as much as possible.
$tb->ok(1, "Running a test to alter TB's state");
my $tmpfile = 'foo.tmp';
$tb->output($tmpfile);
$tb->failure_output($tmpfile);
$tb->todo_output($tmpfile);
END { 1 while unlink $tmpfile }
# This won't print since we just sent output off to oblivion.
$tb->ok(0, "And a failure for fun");
$Test::Builder::Level = 3;
$tb->exported_to('Foofer');
$tb->use_numbers(0);
$tb->no_header(1);
$tb->no_ending(1);
# Now reset it.
$tb->reset;
my $test_num = 2; # since we already printed 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++;
return $test;
}
ok( !defined $tb->exported_to, 'exported_to' );
ok( $tb->expected_tests == 0, 'expected_tests' );
ok( $tb->level == 1, 'level' );
ok( $tb->use_numbers == 1, 'use_numbers' );
ok( $tb->no_header == 0, 'no_header' );
ok( $tb->no_ending == 0, 'no_ending' );
ok( fileno $tb->output == fileno *Test::Builder::TESTOUT,
'output' );
ok( fileno $tb->failure_output == fileno *Test::Builder::TESTERR,
'failure_output' );
ok( fileno $tb->todo_output == fileno *Test::Builder::TESTOUT,
'todo_output' );
ok( $tb->current_test == 0, 'current_test' );
ok( $tb->summary == 0, 'summary' );
ok( $tb->details == 0, 'details' );
$tb->no_ending(1);
$tb->no_header(1);
$tb->plan(tests => 14);
$tb->current_test(13);
$tb->level(0);
$tb->ok(1, 'final test to make sure output was reset');
--- NEW FILE: tbt_03die.t ---
#!/usr/bin/perl
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Test::Builder::Tester tests => 1;
use Test::More;
eval {
test_test("foo");
};
like($@,
"/Not testing\. You must declare output with a test function first\./",
"dies correctly on error");
--- NEW FILE: no_ending.t ---
use Test::Builder;
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
BEGIN {
my $t = Test::Builder->new;
$t->no_ending(1);
}
use Test::More tests => 3;
# Normally, Test::More would yell that we ran too few tests, but we
# supressed the ending diagnostics.
pass;
print "ok 2\n";
print "ok 3\n";
--- NEW FILE: curr_test.t ---
#!/usr/bin/perl -w
# Dave Rolsky found a bug where if current_test() is used and no
# tests are run via Test::Builder it will blow up.
use Test::Builder;
$TB = Test::Builder->new;
$TB->plan(tests => 2);
print "ok 1\n";
print "ok 2\n";
$TB->current_test(2);
--- NEW FILE: threads.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Config;
BEGIN {
unless ( $] >= 5.008 && $Config{'useithreads'} &&
eval { require threads; 'threads'->import; 1; })
{
print "1..0 # Skip: no threads\n";
exit 0;
}
}
use strict;
use Test::Builder;
my $Test = Test::Builder->new;
$Test->exported_to('main');
$Test->plan(tests => 6);
for(1..5) {
'threads'->create(sub {
$Test->ok(1,"Each of these should app the test number")
})->join;
}
$Test->is_num($Test->current_test(), 5,"Should be five");
--- NEW FILE: ok_obj.t ---
#!/usr/bin/perl -w
# Testing to make sure Test::Builder doesn't accidentally store objects
# passed in as test arguments.
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Test::More tests => 4;
package Foo;
my $destroyed = 0;
sub new { bless {}, shift }
sub DESTROY {
$destroyed++;
}
package main;
for (1..3) {
ok(my $foo = Foo->new, 'created Foo object');
}
is $destroyed, 3, "DESTROY called 3 times";
--- NEW FILE: circular_data.t ---
#!/usr/bin/perl -w
# Test is_deeply and friends with circular data structures [rt.cpan.org 7289]
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use strict;
use Test::More tests => 11;
my $a1 = [ 1, 2, 3 ];
push @$a1, $a1;
my $a2 = [ 1, 2, 3 ];
push @$a2, $a2;
is_deeply $a1, $a2;
ok( eq_array ($a1, $a2) );
ok( eq_set ($a1, $a2) );
my $h1 = { 1=>1, 2=>2, 3=>3 };
$h1->{4} = $h1;
my $h2 = { 1=>1, 2=>2, 3=>3 };
$h2->{4} = $h2;
is_deeply $h1, $h2;
ok( eq_hash ($h1, $h2) );
my ($r, $s);
$r = \$r;
$s = \$s;
ok( eq_array ([$s], [$r]) );
{
# Classic set of circular scalar refs.
my($a,$b,$c);
$a = \$b;
$b = \$c;
$c = \$a;
my($d,$e,$f);
$d = \$e;
$e = \$f;
$f = \$d;
is_deeply( $a, $a );
is_deeply( $a, $d );
}
{
# rt.cpan.org 11623
# Make sure the circular ref checks don't get confused by a reference
# which is simply repeating.
my $a = {};
my $b = {};
my $c = {};
is_deeply( [$a, $a], [$b, $c] );
is_deeply( { foo => $a, bar => $a }, { foo => $b, bar => $c } );
is_deeply( [\$a, \$a], [\$b, \$c] );
}
--- NEW FILE: strays.t ---
#!/usr/bin/perl -w
# Check that stray newlines in test output are probably handed.
BEGIN {
print "1..0 # Skip not completed\n";
exit 0;
}
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
chdir 't';
use TieOut;
local *FAKEOUT;
my $out = tie *FAKEOUT, 'TieOut';
use Test::Builder;
my $Test = Test::Builder->new;
my $orig_out = $Test->output;
my $orig_err = $Test->failure_output;
my $orig_todo = $Test->todo_output;
$Test->output(\*FAKEOUT);
$Test->failure_output(\*FAKEOUT);
$Test->todo_output(\*FAKEOUT);
$Test->no_plan();
$Test->ok(1, "name\n");
$Test->ok(0, "foo\nbar\nbaz");
$Test->skip("\nmoofer");
$Test->todo_skip("foo\n\n");
--- NEW FILE: tbt_01basic.t ---
#!/usr/bin/perl
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = '../lib';
}
}
use Test::Builder::Tester tests => 9;
use Test::More;
ok(1,"This is a basic test");
test_out("ok 1 - tested");
ok(1,"tested");
test_test("captured okay on basic");
test_out("ok 1 - tested");
ok(1,"tested");
test_test("captured okay again without changing number");
ok(1,"test unrelated to Test::Builder::Tester");
test_out("ok 1 - one");
test_out("ok 2 - two");
ok(1,"one");
ok(2,"two");
test_test("multiple tests");
test_out("not ok 1 - should fail");
test_err("# Failed test ($0 at line 35)");
test_err("# got: 'foo'");
test_err("# expected: 'bar'");
is("foo","bar","should fail");
test_test("testing failing");
test_out("not ok 1");
test_out("not ok 2");
test_fail(+2);
test_fail(+1);
fail(); fail();
test_test("testing failing on the same line with no name");
test_out("not ok 1 - name");
test_out("not ok 2 - name");
test_fail(+2);
test_fail(+1);
fail("name"); fail("name");
test_test("testing failing on the same line with the same name");
test_out("not ok 1 - name # TODO Something");
test_err("# Failed (TODO) test ($0 at line 59)");
TODO: {
local $TODO = "Something";
fail("name");
}
test_test("testing failing with todo");
--- NEW FILE: details.t ---
#!/usr/bin/perl -w
BEGIN {
if( $ENV{PERL_CORE} ) {
chdir 't';
@INC = ('../lib', 'lib');
}
else {
unshift @INC, 't/lib';
}
}
use Test::More;
use Test::Builder;
my $Test = Test::Builder->new;
$Test->plan( tests => 9 );
$Test->level(0);
my @Expected_Details;
$Test->is_num( scalar $Test->summary(), 0, 'no tests yet, no summary' );
push @Expected_Details, { 'ok' => 1,
actual_ok => 1,
name => 'no tests yet, no summary',
type => '',
reason => ''
};
# Inline TODO tests will confuse pre 1.20 Test::Harness, so we
# should just avoid the problem and not print it out.
my $out_fh = $Test->output;
my $todo_fh = $Test->todo_output;
my $start_test = $Test->current_test + 1;
require TieOut;
tie *FH, 'TieOut';
$Test->output(\*FH);
$Test->todo_output(\*FH);
SKIP: {
$Test->skip( 'just testing skip' );
}
push @Expected_Details, { 'ok' => 1,
actual_ok => 1,
name => '',
type => 'skip',
reason => 'just testing skip',
};
TODO: {
local $TODO = 'i need a todo';
$Test->ok( 0, 'a test to todo!' );
push @Expected_Details, { 'ok' => 1,
actual_ok => 0,
name => 'a test to todo!',
type => 'todo',
reason => 'i need a todo',
};
$Test->todo_skip( 'i need both' );
}
push @Expected_Details, { 'ok' => 1,
actual_ok => 0,
name => '',
type => 'todo_skip',
reason => 'i need both'
};
for ($start_test..$Test->current_test) { print "ok $_\n" }
$Test->output($out_fh);
$Test->todo_output($todo_fh);
$Test->is_num( scalar $Test->summary(), 4, 'summary' );
push @Expected_Details, { 'ok' => 1,
actual_ok => 1,
name => 'summary',
type => '',
reason => '',
};
$Test->current_test(6);
print "ok 6 - current_test incremented\n";
push @Expected_Details, { 'ok' => 1,
actual_ok => undef,
name => undef,
type => 'unknown',
reason => 'incrementing test number',
};
my @details = $Test->details();
$Test->is_num( scalar @details, 6,
'details() should return a list of all test details');
$Test->level(1);
is_deeply( \@details, \@Expected_Details );
# This test has to come last because it thrashes the test details.
{
my $curr_test = $Test->current_test;
$Test->current_test(4);
my @details = $Test->details();
$Test->current_test($curr_test);
$Test->is_num( scalar @details, 4 );
}
More information about the dslinux-commit
mailing list