#!perl -w
BEGIN {
if
(
$ENV
{PERL_CORE} ) {
chdir
't'
;
@INC
= (
'../lib'
,
'lib'
);
}
else
{
unshift
@INC
,
't/lib'
;
}
}
my
(
$out
,
$err
) = Test::Simple::Catch::caught();
local
$ENV
{HARNESS_ACTIVE} = 0;
my
$TB
= Test::Builder->create;
$TB
->plan(
tests
=> 81);
sub
like ($$;$) {
$TB
->like(
@_
);
}
sub
is ($$;$) {
$TB
->is_eq(
@_
);
}
sub
main::out_ok ($$) {
$TB
->is_eq(
$out
->
read
,
shift
);
$TB
->is_eq(
$err
->
read
,
shift
);
}
sub
main::out_warn_ok ($$$) {
$TB
->is_eq(
$out
->
read
,
shift
);
$TB
->is_eq(
$err
->
read
,
shift
);
my
$warning_expected
=
shift
;
$warning_expected
=~ s/^
$TB
->is_eq(
$main::warning
,
$warning_expected
);
}
sub
main::out_like ($$) {
my
(
$output
,
$failure
) =
@_
;
$TB
->like(
$out
->
read
,
qr/$output/
);
$TB
->like(
$err
->
read
,
qr/$failure/
);
}
our
$TODO
;
my
$Total
= 38;
Test::More->
import
(
tests
=>
$Total
);
$out
->
read
;
local
$SIG
{__DIE__} =
sub
{
$TB
->ok(0,
"DIE handler called: "
.
join
""
,
@_
); };
local
$SIG
{__WARN__} =
sub
{
$main::warning
=
$_
[0]; };
my
$tb
= Test::More->builder;
$tb
->use_numbers(0);
my
$Filename
=
quotemeta
$0;
ok( 0,
'failing'
);
out_ok(
<<OUT, <<ERR );
not ok - failing
OUT
ERR
is(
"foo"
,
"bar"
,
'foo is bar?'
);
out_ok(
<<OUT, <<ERR );
not ok - foo is bar?
OUT
ERR
is(
undef
,
''
,
'undef is empty string?'
);
out_ok(
<<OUT, <<ERR );
not ok - undef is empty string?
OUT
ERR
is(
undef
, 0,
'undef is 0?'
);
out_ok(
<<OUT, <<ERR );
not ok - undef is 0?
OUT
ERR
is(
''
, 0,
'empty string is 0?'
);
out_ok(
<<OUT, <<ERR );
not ok - empty string is 0?
OUT
ERR
isnt(
"foo"
,
"foo"
,
'foo isnt foo?'
);
out_ok(
<<OUT, <<ERR );
not ok - foo isnt foo?
OUT
ERR
isn::t(
"foo"
,
"foo"
,
'foo isn\'t foo?'
);
out_warn_ok(
<<OUT, <<ERR, <<WARN );
not ok - foo isn't foo?
OUT
ERR
WARN
isnt(
undef
,
undef
,
'undef isnt undef?'
);
out_ok(
<<OUT, <<ERR );
not ok - undef isnt undef?
OUT
ERR
like(
"foo"
,
'/that/'
,
'is foo like that'
);
out_ok(
<<OUT, <<ERR );
not ok - is foo like that
OUT
ERR
unlike(
"foo"
,
'/foo/'
,
'is foo unlike foo'
);
out_ok(
<<OUT, <<ERR );
not ok - is foo unlike foo
OUT
ERR
like(
"bug"
,
'/(%)/'
,
'regex with % in it'
);
out_ok(
<<OUT, <<ERR );
not ok - regex with % in it
OUT
ERR
fail(
'fail()'
);
out_ok(
<<OUT, <<ERR );
not ok - fail()
OUT
ERR
can_ok(
'Mooble::Hooble::Yooble'
,
qw(this that)
);
out_ok(
<<OUT, <<ERR );
not ok - Mooble::Hooble::Yooble->can(...)
OUT
ERR
can_ok(
'Mooble::Hooble::Yooble'
, ());
out_ok(
<<OUT, <<ERR );
not ok - Mooble::Hooble::Yooble->can(...)
OUT
ERR
can_ok(
undef
,
undef
);
out_ok(
<<OUT, <<ERR );
not ok - ->can(...)
OUT
ERR
can_ok([],
"foo"
);
out_ok(
<<OUT, <<ERR );
not ok - ARRAY->can('foo')
OUT
ERR
isa_ok(
bless
([],
"Foo"
),
"Wibble"
);
out_ok(
<<OUT, <<ERR );
not ok - An object of class 'Foo' isa 'Wibble'
OUT
ERR
isa_ok(42,
"Wibble"
,
"My Wibble"
);
out_ok(
<<OUT, <<ERR );
not ok - 'My Wibble' isa 'Wibble'
OUT
ERR
isa_ok(42,
"Wibble"
);
out_ok(
<<OUT, <<ERR );
not ok - The class (or class-like) '42' isa 'Wibble'
OUT
ERR
isa_ok(
undef
,
"Wibble"
,
"Another Wibble"
);
out_ok(
<<OUT, <<ERR );
not ok - 'Another Wibble' isa 'Wibble'
OUT
ERR
isa_ok([],
"HASH"
);
out_ok(
<<OUT, <<ERR );
not ok - A reference of type 'ARRAY' isa 'HASH'
OUT
ERR
new_ok(
undef
);
out_like(
<<OUT, <<ERR );
not ok - undef->new\\(\\) died
OUT
ERR
new_ok(
"Does::Not::Exist"
);
out_like(
<<OUT, <<ERR );
not ok - Does::Not::Exist->new\\(\\) died
OUT
ERR
{
package
Foo;
sub
new { } }
{
package
Bar;
sub
new { {} } }
{
package
Baz;
sub
new {
bless
{},
"Wibble"
} }
new_ok(
"Foo"
);
out_ok(
<<OUT, <<ERR );
not ok - undef isa 'Foo'
OUT
ERR
new_ok(
"Bar"
);
out_ok(
<<OUT, <<ERR );
not ok - A reference of type 'HASH' isa 'Bar'
OUT
ERR
new_ok(
"Baz"
);
out_ok(
<<OUT, <<ERR );
not ok - An object of class 'Wibble' isa 'Baz'
OUT
ERR
new_ok(
"Baz"
, [],
"no args"
);
out_ok(
<<OUT, <<ERR );
not ok - 'no args' isa 'Baz'
OUT
ERR
cmp_ok(
'foo'
,
'eq'
,
'bar'
,
'cmp_ok eq'
);
out_ok(
<<OUT, <<ERR );
not ok - cmp_ok eq
OUT
ERR
cmp_ok( 42.1,
'=='
, 23, ,
' =='
);
out_ok(
<<OUT, <<ERR );
not ok - ==
OUT
ERR
cmp_ok( 42,
'!='
, 42 ,
' !='
);
out_ok(
<<OUT, <<ERR );
not ok - !=
OUT
ERR
cmp_ok( 1,
'&&'
, 0 ,
' &&'
);
out_ok(
<<OUT, <<ERR );
not ok - &&
OUT
ERR
cmp_ok( 42,
'eq'
,
"foo"
,
' eq with numbers'
);
out_ok(
<<OUT, <<ERR );
not ok - eq with numbers
OUT
ERR
{
my
$warnings
=
''
;
local
$SIG
{__WARN__} =
sub
{
$warnings
.=
join
''
,
@_
};
cmp_ok( 42,
'=='
,
"foo"
,
' == with strings'
);
out_ok(
<<OUT, <<ERR );
not ok - == with strings
OUT
ERR
My::Test::like(
$warnings
,
qr/^Argument "foo" isn't numeric in .* at \(eval in cmp_ok\) $Filename line 415\.\n$/
);
$warnings
=
''
;
}
{
my
$warnings
=
''
;
local
$SIG
{__WARN__} =
sub
{
$warnings
.=
join
''
,
@_
};
cmp_ok(
undef
,
"ne"
,
""
,
"undef ne empty string"
);
$TB
->is_eq(
$out
->
read
,
<<OUT );
not ok - undef ne empty string
OUT
$TB
->is_eq(
$err
->
read
,
<<ERR );
# Failed test 'undef ne empty string'
# at $0 line 437.
# undef
# ne
# ''
ERR
My::Test::like(
$warnings
,
qr/^Use of uninitialized value.* in string ne at \(eval in cmp_ok\) $Filename line 437.\n\z/
);
}
-e
"wibblehibble"
;
my
$Errno_Number
= $!+0;
my
$Errno_String
= $!.
''
;
cmp_ok( $!,
'eq'
,
''
,
' eq with stringified errno'
);
out_ok(
<<OUT, <<ERR );
not ok - eq with stringified errno
OUT
ERR
cmp_ok( $!,
'=='
, -1,
' eq with numerified errno'
);
out_ok(
<<OUT, <<ERR );
not ok - eq with numerified errno
OUT
ERR
use_ok(
'Hooble::mooble::yooble'
);
my
$more_err_re
=
<<ERR;
# Failed test 'use Hooble::mooble::yooble;'
# at $Filename line 447\\.
# Tried to use 'Hooble::mooble::yooble'.
# Error: Can't locate Hooble.* in \\\@INC .*
ERR
out_like(
qr/^\Qnot ok - use Hooble::mooble::yooble;\E\n\z/
,
qr/^$more_err_re/
);
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;'
# at $Filename line 460\\.
# Tried to require 'ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble'.
# Error: Can't locate ALL.* in \\\@INC .*
ERR
out_like(
qr/^\Qnot ok - require ALL::YOUR::BASE::ARE::BELONG::TO::US::wibble;\E\n\z/
,
qr/^$more_err_re/
);
END {
out_like(
<<OUT, <<ERR );
OUT
ERR
exit
(0);
}