1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
use Test2::Tools::Defer;
use strict;
use warnings;
# Make sure convert loads necessary modules (must do before loading the
# extended bundle)
BEGIN {
require Test2::Compare;
def ok => (defined Test2::Compare::convert(undef), "convert returned something to us");
def ok => ($INC{'Test2/Compare/Undef.pm'}, "loaded the Test2::Compare::Undef module");
}
use Test2::Bundle::Extended;
use Test2::API qw/intercept/;
use Data::Dumper;
use Test2::Compare qw{
compare get_build push_build pop_build build
strict_convert relaxed_convert
};
pass "Loaded Test2::Compare";
imported_ok qw{
compare get_build push_build pop_build build
strict_convert relaxed_convert
};
do_def;
{
package Fake::Check;
sub run {
my $self = shift;
return {@_, self => $self}
}
}
my $check = bless {}, 'Fake::Check';
my $convert = sub { $_[-1]->{ran}++; $_[-1] };
my $got = compare('foo', $check, $convert);
like(
$got,
{
self => {ran => 1},
id => undef,
got => 'foo',
convert => sub { $_ == $convert },
seen => {},
},
"check got expected args"
);
is(get_build(), undef, "no build");
like(
dies { pop_build(['a']) },
qr/INTERNAL ERROR: Attempted to pop incorrect build, have undef, tried to pop ARRAY/,
"Got error popping from nothing"
);
push_build(['a']);
is(get_build(), ['a'], "pushed build");
like(
dies { pop_build() },
qr/INTERNAL ERROR: Attempted to pop incorrect build, have ARRAY\(.*\), tried to pop undef/,
"Got error popping undef"
);
like(
dies { pop_build(['a']) },
qr/INTERNAL ERROR: Attempted to pop incorrect build, have ARRAY\(.*\), tried to pop ARRAY/,
"Got error popping wrong ref"
);
# Don't ever actually do this...
ok(pop_build(get_build()), "Popped");
my $inner;
my $build = sub { build('Test2::Compare::Array', sub {
local $_ = 1;
$inner = get_build();
}) }->();
is($build->lines, [__LINE__ - 4, __LINE__ - 1], "got lines");
is($build->file, __FILE__, "got file");
ref_is($inner, $build, "Build was set inside block");
like(
dies { my $x = build('Test2::Compare::Array', sub { die 'xxx' }) },
qr/xxx at/,
"re-threw exception"
);
like(
dies { build('Test2::Compare::Array', sub { }) },
qr/should not be called in void context/,
"You need to retain the return from build"
);
subtest convert => sub {
my $true = do { bless \(my $dummy = 1), "My::Boolean" };
my $false = do { bless \(my $dummy = 0), "My::Boolean" };
my @sets = (
['a', 'String', 'String'],
[undef, 'Undef', 'Undef'],
['', 'String', 'String'],
[1, 'String', 'String'],
[0, 'String', 'String'],
[[], 'Array', 'Array'],
[{}, 'Hash', 'Hash'],
[qr/x/, 'Regex', 'Pattern'],
[sub { 1 }, 'Ref', 'Custom'],
[\*STDERR, 'Ref', 'Ref'],
[\'foo', 'Scalar', 'Scalar'],
[\v1.2.3, 'Scalar', 'Scalar'],
[$true, 'Scalar', 'Scalar'],
[$false, 'Scalar', 'Scalar'],
[
bless({}, 'Test2::Compare::Base'),
'Base',
'Base'
],
[
bless({expect => 'a'}, 'Test2::Compare::Wildcard'),
'String',
'String',
],
);
for my $set (@sets) {
my ($item, $strict, $relaxed) = @$set;
my $name = defined $item ? "'$item'" : 'undef';
my $gs = strict_convert($item);
my $st = join '::', grep {$_} 'Test2::Compare', $strict;
ok($gs->isa($st), "$name -> $st") || diag Dumper($item);
my $gr = relaxed_convert($item);
my $rt = join '::', grep {$_} 'Test2::Compare', $relaxed;
ok($gr->isa($rt), "$name -> $rt") || diag Dumper($item);
}
};
done_testing;
|
