BEGIN {
$ENV
{TABLE_TERM_SIZE} = 80 }
can_ok(
$CLASS
,
qw/check/
);
is(
$CLASS
->can(
'chk'
),
$CLASS
->can(
'check'
),
"chk is aliased to check"
);
my
$one
=
$CLASS
->new();
isa_ok(
$one
,
$CLASS
);
my
$check1
= Test2::Compare::String->new(
input
=>
'x'
);
my
$check2
= Test2::Compare::String->new(
input
=>
'y'
);
$one
=
$CLASS
->new(
check
=>
$check1
);
ref_is(
$one
->chk,
$check1
,
"Got our check"
);
ref_is(
$one
->check,
$check1
,
"Got our check aliased"
);
$one
=
$CLASS
->new(
chk
=>
$check2
);
ref_is(
$one
->chk,
$check2
,
"Got our check"
);
ref_is(
$one
->check,
$check2
,
"Got our check aliased"
);
like(
dies {
$CLASS
->new(
check
=>
$check1
,
chk
=>
$check2
) },
qr/Cannot specify both 'check' and 'chk' as arguments/
,
"Cannot specify both chk and check"
);
subtest
render_got
=>
sub
{
my
$one
=
$CLASS
->new;
is(
$one
->render_got,
'<UNDEF>'
,
"'got' is undef"
);
$one
->set_exception(
'foo'
);
is(
$one
->render_got,
'<EXCEPTION: foo>'
,
"Exception always wins"
);
$one
->set_exception(
undef
);
$one
->set_dne(
'got'
);
is(
$one
->render_got,
'<DOES NOT EXIST>'
,
"'got' does not exist"
);
$one
->set_dne(
'check'
);
is(
$one
->render_got,
'<UNDEF>'
,
"'got' does not exist"
);
$one
->set_dne(
undef
);
$one
->set_got(
'a'
);
is(
$one
->render_got,
'a'
,
"'got' value"
);
$one
->set_got({});
like(
$one
->render_got,
qr/HASH\(.*\)/
,
"'got' ref value"
);
};
subtest
render_check
=>
sub
{
my
$one
=
$CLASS
->new;
my
$check
= Test2::Compare::String->new(
input
=>
'xyz'
);
is(
$one
->render_check,
'<UNDEF>'
,
"check is undef"
);
$one
->set_dne(
'got'
);
is(
$one
->render_check,
'<UNDEF>'
,
"check is undef and dne is 'got'"
);
$one
->set_dne(
'check'
);
is(
$one
->render_check,
'<DOES NOT EXIST>'
,
"check does not exit"
);
$one
->set_dne(
undef
);
$one
->set_check(
$check
);
is(
$one
->render_check,
$check
->render,
"valid check is rendered"
);
};
subtest
_full_id
=>
sub
{
my
$fid
=
$CLASS
->can(
'_full_id'
);
is(
$fid
->(
undef
,
'xxx'
),
'<xxx>'
,
"no type means <ID>"
);
is(
$fid
->(
'META'
,
'xxx'
),
'<xxx>'
,
"META type means <ID>"
);
is(
$fid
->(
'SCALAR'
,
'$*'
),
'$*'
,
"SCALAR type means ID is unchanged"
);
is(
$fid
->(
'HASH'
,
'xxx'
),
'{xxx}'
,
"HASH type means ID is wrapped in {}"
);
is(
$fid
->(
'ARRAY'
,
'12'
),
'[12]'
,
"ARRAY type means ID is wrapped in []"
);
is(
$fid
->(
'METHOD'
,
'foo'
),
'foo()'
,
"METHOD type gets () postfix"
);
};
subtest
_arrow_id
=>
sub
{
my
$aid
=
$CLASS
->can(
'_arrow_id'
);
is(
$aid
->(
'xxx'
,
undef
),
' '
,
"undef gets a space, not an arrow"
);
is(
$aid
->(
'xxx'
,
'META'
),
' '
,
"Meta gets a space, not an arrow"
);
is(
$aid
->(
'xxx'
,
'METHOD'
),
'->'
,
"Method always needs an arrow"
);
is(
$aid
->(
'xxx'
,
'SCALAR'
),
'->'
,
"Scalar always needs an arrow"
);
is(
$aid
->(
'xxx'
,
'HASH'
),
'->'
,
"Hash usually needs an arrow"
);
is(
$aid
->(
'xxx'
,
'ARRAY'
),
'->'
,
"Array usually needs an arrow"
);
is(
$aid
->(
'{xxx}'
,
'HASH'
),
''
,
"Hash needs no arrow after hash"
);
is(
$aid
->(
'{xxx}'
,
'ARRAY'
),
''
,
"Array needs no arrow after hash"
);
is(
$aid
->(
'[xxx]'
,
'HASH'
),
''
,
"Hash needs no arrow after array"
);
is(
$aid
->(
'[xxx]'
,
'ARRAY'
),
''
,
"Array needs no arrow after array"
);
is(
$aid
->(
'<xxx>'
,
'xxx'
),
'->'
,
"Need an arrow after meta, or after a method"
);
is(
$aid
->(
'xxx()'
,
'xxx'
),
'->'
,
"Need an arrow after meta, or after a method"
);
is(
$aid
->(
'$VAR'
,
'xxx'
),
'->'
,
"Need an arrow after the initial ref"
);
is(
$aid
->(
'xxx'
,
''
),
' '
,
"space"
);
is(
$aid
->(
''
,
''
),
''
,
"No arrow needed"
);
};
subtest
_join_id
=>
sub
{
my
$jid
=
$CLASS
->can(
'_join_id'
);
is(
$jid
->(
'{path}'
, [
undef
,
'id'
]),
"{path} <id>"
,
"Hash + undef"
);
is(
$jid
->(
'[path]'
, [
undef
,
'id'
]),
"[path] <id>"
,
"Array + undef"
);
is(
$jid
->(
'path'
, [
undef
,
'id'
]),
"path <id>"
,
"path + undef"
);
is(
$jid
->(
'<path>'
, [
undef
,
'id'
]),
"<path> <id>"
,
"meta + undef"
);
is(
$jid
->(
'path()'
, [
undef
,
'id'
]),
"path() <id>"
,
"meth + undef"
);
is(
$jid
->(
'$VAR'
, [
undef
,
'id'
]),
'$VAR <id>'
,
'$VAR + undef'
);
is(
$jid
->(
''
, [
undef
,
'id'
]),
"<id>"
,
"empty + undef"
);
is(
$jid
->(
'{path}'
, [
'META'
,
'id'
]),
"{path} <id>"
,
"hash + meta"
);
is(
$jid
->(
'[path]'
, [
'META'
,
'id'
]),
"[path] <id>"
,
"array + meta"
);
is(
$jid
->(
'path'
, [
'META'
,
'id'
]),
"path <id>"
,
"path + meta"
);
is(
$jid
->(
'<path>'
, [
'META'
,
'id'
]),
"<path> <id>"
,
"meta + meta"
);
is(
$jid
->(
'path()'
, [
'META'
,
'id'
]),
"path() <id>"
,
"meth + meta"
);
is(
$jid
->(
'$VAR'
, [
'META'
,
'id'
]),
'$VAR <id>'
,
'$VAR + meta'
);
is(
$jid
->(
''
, [
'META'
,
'id'
]),
"<id>"
,
"empty + meta"
);
is(
$jid
->(
'{path}'
, [
'SCALAR'
,
'$*'
]),
'{path}->$*'
,
"Hash + scalar"
);
is(
$jid
->(
'[path]'
, [
'SCALAR'
,
'$*'
]),
'[path]->$*'
,
"Array + scalar"
);
is(
$jid
->(
'path'
, [
'SCALAR'
,
'$*'
]),
'path->$*'
,
"Path + scalar"
);
is(
$jid
->(
'<path>'
, [
'SCALAR'
,
'$*'
]),
'<path>->$*'
,
"Meta + scalar"
);
is(
$jid
->(
'path()'
, [
'SCALAR'
,
'$*'
]),
'path()->$*'
,
"Meth + scalar"
);
is(
$jid
->(
'$VAR'
, [
'SCALAR'
,
'$*'
]),
'$VAR->$*'
,
'$VAR + scalar'
);
is(
$jid
->(
''
, [
'SCALAR'
,
'$*'
]),
'$*'
,
"Empty + scalar"
);
is(
$jid
->(
'{path}'
, [
'HASH'
,
'id'
]),
"{path}{id}"
,
"Hash + hash"
);
is(
$jid
->(
'[path]'
, [
'HASH'
,
'id'
]),
"[path]{id}"
,
"Array + hash"
);
is(
$jid
->(
'path'
, [
'HASH'
,
'id'
]),
"path->{id}"
,
"Path + hash"
);
is(
$jid
->(
'<path>'
, [
'HASH'
,
'id'
]),
"<path>->{id}"
,
"Meta + hash"
);
is(
$jid
->(
'path()'
, [
'HASH'
,
'id'
]),
"path()->{id}"
,
"Meth + hash"
);
is(
$jid
->(
'$VAR'
, [
'HASH'
,
'id'
]),
'$VAR->{id}'
,
'$VAR + hash'
);
is(
$jid
->(
''
, [
'HASH'
,
'id'
]),
"{id}"
,
"Empty + hash"
);
is(
$jid
->(
'{path}'
, [
'ARRAY'
,
'12'
]),
"{path}[12]"
,
"Hash + array"
);
is(
$jid
->(
'[path]'
, [
'ARRAY'
,
'12'
]),
"[path][12]"
,
"Array + array"
);
is(
$jid
->(
'path'
, [
'ARRAY'
,
'12'
]),
"path->[12]"
,
"Path + array"
);
is(
$jid
->(
'<path>'
, [
'ARRAY'
,
'12'
]),
"<path>->[12]"
,
"Meta + array"
);
is(
$jid
->(
'path()'
, [
'ARRAY'
,
'12'
]),
"path()->[12]"
,
"Meth + array"
);
is(
$jid
->(
'$VAR'
, [
'ARRAY'
,
'12'
]),
'$VAR->[12]'
,
'$VAR + array'
);
is(
$jid
->(
''
, [
'ARRAY'
,
'12'
]),
"[12]"
,
"Empty + array"
);
is(
$jid
->(
'{path}'
, [
'METHOD'
,
'id'
]),
"{path}->id()"
,
"Hash + method"
);
is(
$jid
->(
'[path]'
, [
'METHOD'
,
'id'
]),
"[path]->id()"
,
"Array + method"
);
is(
$jid
->(
'path'
, [
'METHOD'
,
'id'
]),
"path->id()"
,
"Path + method"
);
is(
$jid
->(
'<path>'
, [
'METHOD'
,
'id'
]),
"<path>->id()"
,
"Meta + method"
);
is(
$jid
->(
'path()'
, [
'METHOD'
,
'id'
]),
"path()->id()"
,
"Meth + method"
);
is(
$jid
->(
'$VAR'
, [
'METHOD'
,
'id'
]),
'$VAR->id()'
,
'$VAR + method'
);
is(
$jid
->(
''
, [
'METHOD'
,
'id'
]),
"id()"
,
"Empty + method"
);
};
subtest
should_show
=>
sub
{
my
$one
=
$CLASS
->new(
verified
=> 0);
ok(
$one
->should_show,
"not verified, always show"
);
$one
->set_verified(1);
ok(!
$one
->should_show,
"verified, do not show"
);
my
$check
= Test2::Compare::String->new(
input
=>
'xyz'
);
$one
->set_chk(
$check
);
ok(!
$one
->should_show,
"verified, check is uninteresting"
);
$check
->set_lines([1,2]);
ok(!
$one
->should_show,
"verified, check has lines but no file"
);
$check
->set_file(
'foo'
);
ok(!
$one
->should_show,
"verified, check has lines different file"
);
$check
->set_file(__FILE__);
ok(
$one
->should_show,
"Have lines and same file, should show for debug purposes"
);
};
subtest
filter_visible
=>
sub
{
my
$root
=
$CLASS
->new(
verified
=> 1);
my
$child1
=
$CLASS
->new(
verified
=> 0,
id
=> [
HASH
=>
'a'
]);
my
$child2
=
$CLASS
->new(
verified
=> 1,
id
=> [
HASH
=>
'b'
]);
my
$grand1
=
$CLASS
->new(
verified
=> 0,
id
=> [
ARRAY
=> 0],
children
=> []);
my
$grand2
=
$CLASS
->new(
verified
=> 0,
id
=> [
ARRAY
=> 1],
children
=> []);
$root
->set_children([
$child1
,
$child2
]);
$child2
->set_children([
$grand1
,
$grand2
]);
is(
$root
->filter_visible,
[
[
'{a}'
,
$child1
],
[
'{b}[0]'
,
$grand1
],
[
'{b}[1]'
,
$grand2
],
],
"Got visible ones"
);
};
subtest
table_header
=>
sub
{
is(
$CLASS
->table_header, [
qw/PATH LNs GOT OP CHECK LNs/
],
"got header"
);
};
subtest
table_op
=>
sub
{
my
$one
=
$CLASS
->new(
verified
=> 0);
is(
$one
->table_op,
'!exists'
,
"no op if there is no check"
);
my
$check
= Test2::Compare::String->new(
input
=>
'xyz'
);
$one
->set_chk(
$check
);
$one
->set_got(
'foo'
);
is(
$one
->table_op,
'eq'
,
"got op"
);
$one
->set_dne(
'anything'
);
is(
$one
->table_op,
'eq'
,
"got op when dne is set to something other than 'got'"
);
$one
->set_dne(
'got'
);
is(
$one
->table_op,
''
,
"Called check->operator without args since dne is 'got'"
);
};
subtest
table_check_lines
=>
sub
{
my
$one
=
$CLASS
->new(
verified
=> 0);
is(
$one
->table_check_lines,
''
,
'no lines without a check'
);
my
$check
= Test2::Compare::String->new(
input
=>
'xyz'
);
$one
->set_chk(
$check
);
is(
$one
->table_check_lines,
''
,
'check has no lines'
);
$check
->set_lines([]);
is(
$one
->table_check_lines,
''
,
'check has lines, but it is empty'
);
$check
->set_lines([2, 4, 6]);
is(
$one
->table_check_lines,
'2, 4, 6'
,
'got lines'
);
};
subtest
table_got_lines
=>
sub
{
my
$one
=
$CLASS
->new(
verified
=> 0);
is(
$one
->table_got_lines,
''
,
"no lines without a check"
);
my
$check
= Test2::Compare::String->new(
input
=>
'xyz'
);
$one
->set_chk(
$check
);
$one
->set_dne(
'got'
);
is(
$one
->table_got_lines,
''
,
"no lines when 'got' is dne"
);
$one
->set_dne(
'anything'
);
is(
$one
->table_got_lines,
''
,
"no lines found with other dne"
);
$one
->set_dne(
''
);
is(
$one
->table_got_lines,
''
,
"no lines found by check"
);
my
$c
= mock
'Test2::Compare::Base'
=> (
override
=> [
got_lines
=>
sub
{(2, 4, 6)},
],
);
is(
$one
->table_got_lines,
'2, 4, 6'
,
"got lines"
);
};
subtest
table_rows
=>
sub
{
my
$one
=
$CLASS
->new(
verified
=> 0);
my
$mock
= mock
$CLASS
=> (
override
=> [
filter_visible
=>
sub
{ [[
'{foo}'
,
$one
], [
'{bar}'
,
$one
]] },
render_check
=>
sub
{
'CHECK!'
},
render_got
=>
sub
{
'GOT!'
},
table_op
=>
sub
{
'OP!'
},
table_check_lines
=>
sub
{
'CHECK LINES!'
},
table_got_lines
=>
sub
{
'GOT LINES!'
},
],
);
my
$rows
=
$one
->table_rows;
$mock
=
undef
;
is(
$rows
,
[
[
'{foo}'
,
'GOT LINES!'
,
'GOT!'
,
'OP!'
,
'CHECK!'
,
'CHECK LINES!'
],
[
'{bar}'
,
'GOT LINES!'
,
'GOT!'
,
'OP!'
,
'CHECK!'
,
'CHECK LINES!'
],
],
"got rows"
);
};
subtest
table
=>
sub
{
local
$ENV
{TS_MAX_DELTA} = 10;
my
$rows
;
my
$mock
= mock
$CLASS
=> (
override
=> [
table_rows
=>
sub
{
return
$rows
}]);
my
$one
=
$CLASS
->new();
$rows
= [
[
'{foo}'
,
'GOT LINES!'
,
'GOT!'
,
'OP!'
,
'CHECK!'
,
'CHECK LINES!'
],
[
'{bar}'
,
'GOT LINES!'
,
'GOT!'
,
'OP!'
,
'CHECK!'
,
'CHECK LINES!'
],
[
'{baz}'
,
'GOT LINES!'
,
'GOT!'
,
'OP!'
,
'CHECK!'
,
'CHECK LINES!'
],
[
'{bat}'
,
'GOT LINES!'
,
'GOT!'
,
'OP!'
,
'CHECK!'
,
'CHECK LINES!'
],
];
def
is
=> (
[
split
/\n/,
$one
->table->as_string],
[
'+-------+------------+------+-----+--------+--------------+'
,
'| PATH | LNs | GOT | OP | CHECK | LNs |'
,
'+-------+------------+------+-----+--------+--------------+'
,
'| {foo} | GOT LINES! | GOT! | OP! | CHECK! | CHECK LINES! |'
,
'| {bar} | GOT LINES! | GOT! | OP! | CHECK! | CHECK LINES! |'
,
'| {baz} | GOT LINES! | GOT! | OP! | CHECK! | CHECK LINES! |'
,
'| {bat} | GOT LINES! | GOT! | OP! | CHECK! | CHECK LINES! |'
,
'+-------+------------+------+-----+--------+--------------+'
,
],
"Got expected table"
);
$rows
= [
[
'{foo}'
,
'GOT LINES!'
,
'GOT!'
,
'OP!'
,
'CHECK!'
,
'CHECK LINES!'
],
[
'{bar}'
,
'GOT LINES!'
,
'GOT!'
,
'OP!'
,
'CHECK!'
,
'CHECK LINES!'
],
[
'{baz}'
,
'GOT LINES!'
,
'GOT!'
,
'OP!'
,
'CHECK!'
,
'CHECK LINES!'
],
[
'{bat}'
,
'GOT LINES!'
,
'GOT!'
,
'OP!'
,
'CHECK!'
,
'CHECK LINES!'
],
];
$ENV
{TS_MAX_DELTA} = 2;
def
is
=> (
[
split
/\n/,
$one
->table->as_string],
[
'+-------+------------+------+-----+--------+--------------+'
,
'| PATH | LNs | GOT | OP | CHECK | LNs |'
,
'+-------+------------+------+-----+--------+--------------+'
,
'| {foo} | GOT LINES! | GOT! | OP! | CHECK! | CHECK LINES! |'
,
'| {bar} | GOT LINES! | GOT! | OP! | CHECK! | CHECK LINES! |'
,
'+-------+------------+------+-----+--------+--------------+'
,
'************************************************************'
,
'* Stopped after 2 differences. *'
,
'* Set the TS_MAX_DELTA environment var to raise the limit. *'
,
'* Set it to 0 for no limit. *'
,
'************************************************************'
,
],
"Got expected table and warning"
);
$ENV
{TS_MAX_DELTA} = 25;
$rows
= [
[
'{foo}'
,
''
,
''
,
''
,
''
,
''
],
[
'{bar}'
,
''
,
''
,
''
,
''
,
''
],
[
'{baz}'
,
''
,
''
,
''
,
''
,
''
],
[
'{bat}'
,
''
,
''
,
''
,
''
,
''
],
];
def
is
=> (
[
split
/\n/,
$one
->table->as_string],
[
'+-------+-----+-------+'
,
'| PATH | GOT | CHECK |'
,
'+-------+-----+-------+'
,
'| {foo} | | |'
,
'| {bar} | | |'
,
'| {baz} | | |'
,
'| {bat} | | |'
,
'+-------+-----+-------+'
,
],
"'GOT' and 'CHECK' never collapse"
);
$mock
=
undef
;
delete
$ENV
{TS_MAX_DELTA};
do_def();
};
subtest
custom_columns
=>
sub
{
my
$conv
= Test2::Compare->can(
'strict_convert'
);
my
$comp
= Test2::Compare->can(
'compare'
);
my
$cmp
=
sub
{
my
$ctx
= context();
my
$delta
=
$comp
->(
@_
,
$conv
);
my
$table
=
$delta
->table;
$ctx
->release;
return
[
split
/\n/,
$table
->as_string];
};
$CLASS
->add_column(
'V'
=>
sub
{
my
(
$d
) =
@_
;
return
$d
->verified ?
'*'
:
''
;
});
my
$table
=
$cmp
->(
{
foo
=> [
'x'
,
'y'
] },
hash {
field
foo
=> array {
item
'a'
;
item
'b'
;
};
},
);
like(
$table
,
[
qr/\Q+---+\E$/
,
qr/\Q| V |\E$/
,
qr/\Q+---+\E$/
,
qr/\Q| * |\E$/
,
qr/\Q| * |\E$/
,
qr/\Q| |\E$/
,
qr/\Q| |\E$/
,
qr/\Q+---+\E$/
,
DNE()
],
"Got new column, it is last"
);
$table
=
$cmp
->(
[
'x'
,
'y'
],
[
'a'
,
'b'
],
);
is(
$table
->[1], mismatch
qr/\Q| V |\E/
,
"Column not shown, it is empty"
);
is(
$CLASS
->remove_column(
'V'
), 1,
"Removed the column"
);
is(
$CLASS
->remove_column(
'V'
), 0,
"No column to remove"
);
$CLASS
->add_column(
'V'
,
value
=>
sub
{
my
(
$d
) =
@_
;
return
$d
->verified ?
'*'
:
''
;
},
alias
=>
'?'
,
no_collapse
=> 1,
prefix
=> 1,
);
$table
=
$cmp
->(
{
foo
=> [
'x'
,
'y'
] },
hash {
field
foo
=> array {
item
'a'
;
item
'b'
;
};
},
);
like(
$table
,
[
qr/^\Q+---+\E/
,
qr/^\Q| ? |\E/
,
qr/^\Q+---+\E/
,
qr/^\Q| * |\E/
,
qr/^\Q| * |\E/
,
qr/^\Q| |\E/
,
qr/^\Q| |\E/
,
qr/^\Q+---+\E/
,
DNE()
],
"Got new column, it is first"
);
$table
=
$cmp
->(
[
'x'
,
'y'
],
[
'a'
,
'b'
],
);
like(
$table
,
[
qr/^\Q+---+\E/
,
qr/^\Q| ? |\E/
,
qr/^\Q+---+\E/
,
qr/^\Q| |\E/
,
qr/^\Q| |\E/
,
qr/^\Q+---+\E/
,
DNE()
],
"Did not collapse"
);
is(
$CLASS
->remove_column(
'V'
), 1,
"Removed the column"
);
is(
$CLASS
->remove_column(
'V'
), 0,
"No column to remove"
);
like(
dies {
$CLASS
->add_column },
qr/Column name is required/
,
"Column name is required"
);
like(
dies {
$CLASS
->add_column(
'FOO'
) },
qr/You must specify a 'value' callback/
,
"Need value callback"
);
like(
dies {
$CLASS
->add_column(
'FOO'
,
'foo'
) },
qr/'value' callback must be a CODE reference/
,
"Need value callback"
);
$CLASS
->add_column(
'FOO'
=>
sub
{
''
});
like(
dies {
$CLASS
->add_column(
'FOO'
=>
sub
{
''
}) },
qr/Column 'FOO' is already defined/
,
"No duplicates"
);
is(
$CLASS
->remove_column(
'FOO'
), 1,
"Removed the column"
);
};
subtest
set_column_alias
=>
sub
{
$CLASS
->set_column_alias(
PATH
=>
' '
);
is(
$CLASS
->table_header,
[
' '
,
qw/LNs GOT OP CHECK LNs/
],
"hide column name"
);
$CLASS
->set_column_alias(
GLNs
=>
'Now This'
);
is(
$CLASS
->table_header,
[
' '
,
'Now This'
,
qw/GOT OP CHECK LNs/
],
"column name with spaces"
);
$CLASS
->add_column(
'NEW'
=>
sub
{
''
});
$CLASS
->set_column_alias(
NEW
=>
'OLD'
);
is(
$CLASS
->table_header,
[
' '
,
'Now This'
,
qw/GOT OP CHECK LNs OLD/
],
"change added column name"
);
like(
dies {
$CLASS
->set_column_alias(
'OP'
) },
qr/Missing alias/
,
'Missing alias'
);
like(
dies {
$CLASS
->set_column_alias(
DNE
=>
'NOPE'
) },
qr/Tried to alias a non-existent column/
,
'Needs existing column name'
);
};
subtest
overload
=>
sub
{
no
warnings
'once'
;
{
'""'
=>
sub
{
'FOO'
},
'0+'
=>
sub
{ 42 };
'""'
=>
sub
{
'BAR'
},
'0+'
=>
sub
{ 99 };
}
my
$foo
=
bless
\
*FOO
,
'Overload::Foo'
;
my
$bar
=
bless
\
*BAR
,
'Overload::Bar'
;
is(
"$foo"
,
"FOO"
,
"overloaded string form FOO"
);
is(
"$bar"
,
"BAR"
,
"overloaded string form BAR"
);
is(
int
(
$foo
), 42,
"overloaded number form FOO"
);
is(
int
(
$bar
), 99,
"overloaded number form BAR"
);
my
$conv
= Test2::Compare->can(
'strict_convert'
);
my
$comp
= Test2::Compare->can(
'compare'
);
my
$cmp
=
sub
{
my
$ctx
= context();
my
$delta
=
$comp
->(
@_
,
$conv
);
my
$table
=
$delta
->table;
$ctx
->release;
return
[
split
/\n/,
$table
->as_string];
};
my
$table
=
$cmp
->(
$foo
,
$bar
);
my
@checks
;
if
(
@$table
== 5) {
@checks
= (
qr/^\| Overload::Foo=GLOB\(.+\)\s+\| ==\s+\| Overload::Bar=GLOB\(.+\)\s+\|$/
,
);
}
else
{
@checks
= (
qr/^\| Overload::Foo=GLOB\(.+\s+\| ==\s+\| Overload::Bar=GLOB\(.+\s+\|$/
,
qr/^\| .*\)\s+\| \s+\| .*\)\s+\|$/
,
);
}
like(
$table
,
[
T(),
T(),
T(),
@checks
,
T(),
DNE(),
],
"Showed type+mem address, despire overloading"
);
};
done_testing;