line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# |
2
|
|
|
|
|
|
|
# First we define some cuckoo packages that we're going to use |
3
|
|
|
|
|
|
|
# |
4
|
|
|
|
|
|
|
package Test::Mini::Exception; |
5
|
4
|
|
|
4
|
|
1506
|
use parent -norequire, 'Exception::Class::Base'; |
|
4
|
|
|
|
|
355
|
|
|
4
|
|
|
|
|
35
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
package Test::Mini::Exception::Assert; |
8
|
4
|
|
|
4
|
|
230
|
use parent -norequire, 'Test::Mini::Exception'; |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
30
|
|
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
package Test::Mini::Exception::Skip; |
11
|
4
|
|
|
4
|
|
189
|
use parent -norequire, 'Test::Mini::Exception::Assert'; |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
17
|
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
# |
14
|
|
|
|
|
|
|
# And then we have the module proper itself |
15
|
|
|
|
|
|
|
# |
16
|
|
|
|
|
|
|
# Basic Assertions for Test::Mini. |
17
|
|
|
|
|
|
|
# |
18
|
|
|
|
|
|
|
package Test::Mini::Assertions; |
19
|
4
|
|
|
4
|
|
223
|
use 5.006; |
|
4
|
|
|
|
|
11
|
|
20
|
4
|
|
|
4
|
|
17
|
use strict; |
|
4
|
|
|
|
|
6
|
|
|
4
|
|
|
|
|
84
|
|
21
|
4
|
|
|
4
|
|
17
|
use warnings; |
|
4
|
|
|
|
|
6
|
|
|
4
|
|
|
|
|
112
|
|
22
|
|
|
|
|
|
|
|
23
|
4
|
|
|
4
|
|
18
|
use Scalar::Util qw/ looks_like_number refaddr reftype /; |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
306
|
|
24
|
4
|
|
|
4
|
|
19
|
use List::Util qw/ min any /; |
|
4
|
|
|
|
|
6
|
|
|
4
|
|
|
|
|
435
|
|
25
|
4
|
|
|
4
|
|
3164
|
use Data::Inspect; |
|
4
|
|
|
|
|
36266
|
|
|
4
|
|
|
|
|
839
|
|
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
# Formats error messages, |
28
|
|
|
|
|
|
|
# appending periods and defaulting undefs as appropriate. |
29
|
|
|
|
|
|
|
sub message { |
30
|
|
|
|
|
|
|
my ($default, $msg) = @_; |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
$msg .= $msg ? ".\n" : ''; |
33
|
|
|
|
|
|
|
$msg .= "$default."; |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
return sub { return $msg }; |
36
|
|
|
|
|
|
|
} |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
# Dereferences the given argument, if possible. |
39
|
|
|
|
|
|
|
sub deref { |
40
|
|
|
|
|
|
|
my ($ref) = @_; |
41
|
|
|
|
|
|
|
return %$ref if reftype($ref) eq 'HASH'; |
42
|
|
|
|
|
|
|
return @$ref if reftype($ref) eq 'ARRAY'; |
43
|
|
|
|
|
|
|
return $$ref if reftype($ref) eq 'SCALAR'; |
44
|
|
|
|
|
|
|
return $$ref if reftype($ref) eq 'REF'; |
45
|
|
|
|
|
|
|
return refaddr($ref); |
46
|
|
|
|
|
|
|
} |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
# Produce a more useful string representation of the given argument. |
49
|
|
|
|
|
|
|
sub inspect { |
50
|
|
|
|
|
|
|
Data::Inspect->new()->inspect(@_); |
51
|
|
|
|
|
|
|
} |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
my $assertion_count = 0; |
54
|
|
|
|
|
|
|
|
55
|
4
|
|
|
4
|
|
2878
|
use namespace::clean; |
|
4
|
|
|
|
|
66271
|
|
|
4
|
|
|
|
|
19
|
|
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
# Pulls all of the test-related methods into the calling package. |
58
|
|
|
|
|
|
|
sub import { |
59
|
7
|
|
|
7
|
|
256
|
my ($class) = @_; |
60
|
7
|
|
|
|
|
15
|
my $caller = caller; |
61
|
|
|
|
|
|
|
|
62
|
4
|
|
|
4
|
|
913
|
no strict 'refs'; |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
13046
|
|
63
|
7
|
|
|
|
|
11
|
*{"$caller\::count_assertions"} = \&_count_assertions; |
|
7
|
|
|
|
|
40
|
|
64
|
7
|
|
|
|
|
15
|
*{"$caller\::reset_assertions"} = \&_reset_assertions; |
|
7
|
|
|
|
|
32
|
|
65
|
|
|
|
|
|
|
|
66
|
7
|
100
|
|
|
|
10
|
my @asserts = grep { /^(assert|refute|skip$|flunk$)/ && defined &{$_} } keys %{"$class\::"}; |
|
294
|
|
|
|
|
745
|
|
|
238
|
|
|
|
|
779
|
|
|
7
|
|
|
|
|
57
|
|
67
|
|
|
|
|
|
|
|
68
|
7
|
|
|
|
|
24
|
for my $assertion (@asserts) { |
69
|
238
|
|
|
|
|
254
|
*{"$caller\::$assertion"} = \&{$assertion}; |
|
238
|
|
|
|
|
3006
|
|
|
238
|
|
|
|
|
369
|
|
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
} |
72
|
|
|
|
|
|
|
|
73
|
51
|
|
|
51
|
|
489
|
sub _count_assertions { return $assertion_count } |
74
|
|
|
|
|
|
|
sub _reset_assertions { |
75
|
54
|
|
|
54
|
|
83
|
my $final_count = $assertion_count; |
76
|
54
|
|
|
|
|
62
|
$assertion_count = 0; |
77
|
54
|
|
|
|
|
161
|
return $final_count; |
78
|
|
|
|
|
|
|
} |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
# ======================== |
81
|
|
|
|
|
|
|
# Exported Functions |
82
|
|
|
|
|
|
|
# ======================== |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
# Assert that $test is truthy, and throw a Test::Mini::Exception::Assert |
85
|
|
|
|
|
|
|
# if that assertion fails. |
86
|
|
|
|
|
|
|
sub assert ($;$) { |
87
|
273
|
|
|
273
|
1
|
2640
|
my ($test, $msg) = @_; |
88
|
273
|
|
100
|
|
|
525
|
$msg ||= 'Assertion failed; no message given.'; |
89
|
273
|
100
|
|
|
|
577
|
$msg = $msg->() if ref $msg eq 'CODE'; |
90
|
|
|
|
|
|
|
|
91
|
273
|
|
|
|
|
290
|
$assertion_count++; |
92
|
|
|
|
|
|
|
|
93
|
273
|
100
|
|
|
|
1467
|
return 1 if $test; |
94
|
|
|
|
|
|
|
|
95
|
1
|
|
|
|
|
9
|
Test::Mini::Exception::Assert->throw( |
96
|
|
|
|
|
|
|
message => $msg, |
97
|
|
|
|
|
|
|
ignore_package => [__PACKAGE__], |
98
|
|
|
|
|
|
|
); |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
# Asserts that $test is falsey, and throw a Test::Mini::Exception::Assert |
102
|
|
|
|
|
|
|
# if that assertion fails. |
103
|
|
|
|
|
|
|
sub refute ($;$) { |
104
|
107
|
|
|
107
|
1
|
226
|
my ($test, $msg) = @_; |
105
|
107
|
|
100
|
|
|
214
|
$msg ||= 'Refutation failed; no message given.'; |
106
|
107
|
|
|
|
|
251
|
return assert(!$test, $msg); |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
# Asserts that the given code reference returns a truthy value. |
110
|
|
|
|
|
|
|
# DEPRECATED - this will be removed in v2.0.0. |
111
|
|
|
|
|
|
|
sub assert_block (&;$) { |
112
|
6
|
|
|
6
|
1
|
130
|
my ($block, $msg) = @_; |
113
|
6
|
|
|
|
|
15
|
warn '#assert_block is deprecated; please use #assert instead.'; |
114
|
6
|
50
|
33
|
|
|
53
|
($msg, $block) = ($block, $msg) if $msg && ref $block ne 'CODE'; |
115
|
6
|
|
|
|
|
15
|
$msg = message('Expected block to return true value', $msg); |
116
|
6
|
|
|
|
|
14
|
assert_instance_of($block, 'CODE'); |
117
|
6
|
|
|
|
|
38
|
assert($block->(), $msg); |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
# Asserts that the given code reference returns a falsey value. |
121
|
|
|
|
|
|
|
# DEPRECATED - this will be removed in v2.0.0. |
122
|
|
|
|
|
|
|
sub refute_block (&;$) { |
123
|
6
|
|
|
6
|
1
|
125
|
my ($block, $msg) = @_; |
124
|
6
|
|
|
|
|
16
|
warn '#refute_block is deprecated; please use #refute instead.'; |
125
|
6
|
50
|
33
|
|
|
45
|
($msg, $block) = ($block, $msg) if $msg && ref $block ne 'CODE'; |
126
|
6
|
|
|
|
|
11
|
$msg = message('Expected block to return false value', $msg); |
127
|
6
|
|
|
|
|
11
|
assert_instance_of($block, 'CODE'); |
128
|
6
|
|
|
|
|
37
|
refute($block->(), $msg); |
129
|
|
|
|
|
|
|
} |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
# Verifies that the given $obj is capable of responding to the given |
132
|
|
|
|
|
|
|
# $method name. |
133
|
|
|
|
|
|
|
sub assert_can ($$;$) { |
134
|
24
|
|
|
24
|
1
|
64
|
my ($obj, $method, $msg) = @_; |
135
|
24
|
|
50
|
|
|
29
|
$msg = message("Expected @{[inspect($obj)]} (@{[ref $obj || 'SCALAR']}) to respond to #$method", $msg); |
|
24
|
|
|
|
|
38
|
|
|
24
|
|
|
|
|
2798
|
|
136
|
24
|
|
|
|
|
154
|
assert($obj->can($method), $msg); |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
|
139
|
|
|
|
|
|
|
# Verifies that the given $obj is *not* capable of responding to the given |
140
|
|
|
|
|
|
|
# $method name. |
141
|
|
|
|
|
|
|
sub refute_can ($$;$) { |
142
|
4
|
|
|
4
|
1
|
40
|
my ($obj, $method, $msg) = @_; |
143
|
4
|
|
50
|
|
|
7
|
$msg = message("Expected @{[inspect($obj)]} (@{[ref $obj || 'SCALAR']}) to not respond to #$method", $msg); |
|
4
|
|
|
|
|
10
|
|
|
4
|
|
|
|
|
276
|
|
144
|
4
|
|
|
|
|
26
|
refute($obj->can($method), $msg); |
145
|
|
|
|
|
|
|
} |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
# Verifies that the given $collection contains the given $obj as a member. |
148
|
|
|
|
|
|
|
sub assert_contains ($$;$) { |
149
|
31
|
|
|
31
|
1
|
3607
|
my ($collection, $obj, $msg) = @_; |
150
|
31
|
|
|
|
|
45
|
my $m = message("Expected @{[inspect($collection)]} to contain @{[inspect($obj)]}", $msg); |
|
31
|
|
|
|
|
58
|
|
|
31
|
|
|
|
|
4446
|
|
151
|
31
|
100
|
|
|
|
201
|
if (ref $collection eq 'ARRAY') { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
152
|
10
|
50
|
|
20
|
|
48
|
my $search = any {defined $obj ? $_ eq $obj : defined $_ } @$collection; |
|
20
|
|
|
|
|
51
|
|
153
|
10
|
|
|
|
|
73
|
assert($search, $m); |
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
elsif (ref $collection eq 'HASH') { |
156
|
6
|
|
|
|
|
26
|
&assert_contains([%$collection], $obj, $msg); |
157
|
|
|
|
|
|
|
} |
158
|
|
|
|
|
|
|
elsif (ref $collection) { |
159
|
6
|
|
|
|
|
45
|
assert_can($collection, 'contains'); |
160
|
6
|
|
|
|
|
79
|
assert($collection->contains($obj), $m); |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
else { |
163
|
9
|
|
|
|
|
34
|
assert(index($collection, $obj) != -1, $m); |
164
|
|
|
|
|
|
|
} |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
# Verifies that the given $collection does not contain the given $obj as a |
168
|
|
|
|
|
|
|
# member. |
169
|
|
|
|
|
|
|
sub refute_contains ($$;$) { |
170
|
26
|
|
|
26
|
1
|
175
|
my ($collection, $obj, $msg) = @_; |
171
|
26
|
|
|
|
|
29
|
my $m = message("Expected @{[inspect($collection)]} to not contain @{[inspect($obj)]}", $msg); |
|
26
|
|
|
|
|
48
|
|
|
26
|
|
|
|
|
3612
|
|
172
|
26
|
100
|
|
|
|
151
|
if (ref $collection eq 'ARRAY') { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
173
|
10
|
50
|
|
20
|
|
44
|
my $search = any {defined $obj ? $_ eq $obj : defined $_ } @$collection; |
|
20
|
|
|
|
|
45
|
|
174
|
10
|
|
|
|
|
32
|
refute($search, $m); |
175
|
|
|
|
|
|
|
} |
176
|
|
|
|
|
|
|
elsif (ref $collection eq 'HASH') { |
177
|
6
|
|
|
|
|
19
|
&refute_contains([%$collection], $obj, $msg); |
178
|
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
|
elsif (ref $collection) { |
180
|
6
|
|
|
|
|
16
|
assert_can($collection, 'contains'); |
181
|
6
|
|
|
|
|
79
|
refute($collection->contains($obj), $m); |
182
|
|
|
|
|
|
|
} |
183
|
|
|
|
|
|
|
else { |
184
|
4
|
|
|
|
|
25
|
refute(index($collection, $obj) != -1, $m); |
185
|
|
|
|
|
|
|
} |
186
|
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
|
|
188
|
|
|
|
|
|
|
# Validates that the given $obj is defined. |
189
|
|
|
|
|
|
|
sub assert_defined ($;$) { |
190
|
12
|
|
|
12
|
1
|
92
|
my ($obj, $msg) = @_; |
191
|
12
|
|
|
|
|
22
|
$msg = message("Expected @{[inspect($obj)]} to be defined", $msg); |
|
12
|
|
|
|
|
20
|
|
192
|
12
|
|
|
|
|
47
|
assert(defined $obj, $msg); |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
# Validates that the given $obj is not defined. |
196
|
6
|
|
|
6
|
0
|
87
|
sub refute_defined ($;$) { goto &assert_undef } |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
# Tests that the supplied code block dies, and fails if it succeeds. If |
199
|
|
|
|
|
|
|
# $error is provided, the error message in $@ must contain it. |
200
|
|
|
|
|
|
|
sub assert_dies (&;$$) { |
201
|
5
|
|
|
5
|
1
|
83
|
my ($sub, $error, $msg) = @_; |
202
|
5
|
100
|
|
|
|
16
|
$error = '' unless defined $error; |
203
|
|
|
|
|
|
|
|
204
|
5
|
|
|
|
|
7
|
$msg = message("Expected @{[inspect($sub)]} to die matching /$error/", $msg); |
|
5
|
|
|
|
|
9
|
|
205
|
5
|
|
|
|
|
15
|
my ($full_error, $dies); |
206
|
|
|
|
|
|
|
{ |
207
|
5
|
|
|
|
|
6
|
local $@; |
|
5
|
|
|
|
|
6
|
|
208
|
5
|
|
|
|
|
7
|
$dies = not eval { $sub->(); return 1; }; |
|
5
|
|
|
|
|
15
|
|
|
2
|
|
|
|
|
6
|
|
209
|
5
|
|
|
|
|
9
|
$full_error = $@; |
210
|
|
|
|
|
|
|
} |
211
|
5
|
|
|
|
|
14
|
assert($dies, $msg); |
212
|
5
|
|
|
|
|
31
|
assert_contains("$full_error", $error); |
213
|
|
|
|
|
|
|
} |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
# Verifies the emptiness of a collection. |
216
|
|
|
|
|
|
|
sub assert_empty ($;$) { |
217
|
10
|
|
|
10
|
1
|
177
|
my ($collection, $msg) = @_; |
218
|
10
|
|
|
|
|
13
|
$msg = message("Expected @{[inspect($collection)]} to be empty", $msg); |
|
10
|
|
|
|
|
20
|
|
219
|
10
|
100
|
|
|
|
55
|
if (ref $collection eq 'ARRAY') { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
220
|
2
|
|
|
|
|
7
|
refute(@$collection, $msg); |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
elsif (ref $collection eq 'HASH') { |
223
|
2
|
|
|
|
|
8
|
refute(keys %$collection, $msg); |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
elsif (ref $collection) { |
226
|
4
|
|
|
|
|
140
|
assert_can($collection, 'is_empty'); |
227
|
4
|
|
|
|
|
48
|
assert($collection->is_empty(), $msg); |
228
|
|
|
|
|
|
|
} |
229
|
|
|
|
|
|
|
else { |
230
|
2
|
|
|
|
|
5
|
refute(length $collection, $msg); |
231
|
|
|
|
|
|
|
} |
232
|
|
|
|
|
|
|
} |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
# Verifies the non-emptiness of a collection. |
235
|
|
|
|
|
|
|
sub refute_empty ($;$) { |
236
|
10
|
|
|
10
|
1
|
192
|
my ($collection, $msg) = @_; |
237
|
10
|
|
|
|
|
15
|
$msg = message("Expected @{[inspect($collection)]} to not be empty", $msg); |
|
10
|
|
|
|
|
17
|
|
238
|
10
|
100
|
|
|
|
58
|
if (ref $collection eq 'ARRAY') { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
239
|
2
|
|
|
|
|
6
|
assert(@$collection, $msg); |
240
|
|
|
|
|
|
|
} |
241
|
|
|
|
|
|
|
elsif (ref $collection eq 'HASH') { |
242
|
2
|
|
|
|
|
9
|
assert(keys %$collection, $msg); |
243
|
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
|
elsif (ref $collection) { |
245
|
4
|
|
|
|
|
7
|
assert_can($collection, 'is_empty'); |
246
|
4
|
|
|
|
|
77
|
refute($collection->is_empty(), $msg); |
247
|
|
|
|
|
|
|
} |
248
|
|
|
|
|
|
|
else { |
249
|
2
|
|
|
|
|
8
|
assert(length $collection, $msg); |
250
|
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
# Checks two given arguments for equality. |
254
|
25
|
|
|
25
|
0
|
472
|
sub assert_eq { goto &assert_equal } |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
# Checks two given arguments for inequality. |
257
|
25
|
|
|
25
|
0
|
481
|
sub refute_eq { goto &refute_equal } |
258
|
|
|
|
|
|
|
|
259
|
|
|
|
|
|
|
# Checks two given arguments for equality. |
260
|
|
|
|
|
|
|
sub assert_equal ($$;$) { |
261
|
74
|
|
|
74
|
1
|
2024
|
my ($actual, $expected, $msg) = @_; |
262
|
74
|
|
|
|
|
181
|
$msg = message("Got @{[inspect($actual)]}\nnot @{[inspect($expected)]}", $msg); |
|
74
|
|
|
|
|
152
|
|
|
74
|
|
|
|
|
57093
|
|
263
|
|
|
|
|
|
|
|
264
|
74
|
|
|
|
|
385
|
my @expected = ($expected); |
265
|
74
|
|
|
|
|
118
|
my @actual = ($actual); |
266
|
|
|
|
|
|
|
|
267
|
74
|
|
|
|
|
94
|
my $passed = 1; |
268
|
|
|
|
|
|
|
|
269
|
74
|
|
66
|
|
|
335
|
while ($passed && (@actual || @expected)) { |
|
|
|
66
|
|
|
|
|
270
|
1156
|
|
|
|
|
1875
|
($actual, $expected) = (shift(@actual), shift(@expected)); |
271
|
|
|
|
|
|
|
|
272
|
1156
|
100
|
66
|
|
|
3154
|
next if ref $actual && ref $expected && refaddr($actual) == refaddr($expected); |
|
|
|
100
|
|
|
|
|
273
|
|
|
|
|
|
|
|
274
|
1150
|
100
|
66
|
|
|
1433
|
if (eval { $expected->can('equals') }) { |
|
1150
|
100
|
66
|
|
|
15767
|
|
|
|
100
|
66
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
275
|
8
|
|
|
|
|
29
|
$passed = $expected->equals($actual); |
276
|
|
|
|
|
|
|
} |
277
|
|
|
|
|
|
|
elsif (ref $actual eq 'ARRAY' && ref $expected eq 'ARRAY') { |
278
|
24
|
|
|
|
|
45
|
$passed = (@$actual == @$expected); |
279
|
24
|
|
|
|
|
52
|
unshift @actual, @$actual; |
280
|
24
|
|
|
|
|
118
|
unshift @expected, @$expected; |
281
|
|
|
|
|
|
|
} |
282
|
|
|
|
|
|
|
elsif (ref $actual eq 'HASH' && ref $expected eq 'HASH') { |
283
|
10
|
|
|
|
|
22
|
$passed = (keys %$actual == keys %$expected); |
284
|
10
|
|
|
|
|
285
|
unshift @actual, map {$_, $actual->{$_} } sort keys %$actual; |
|
520
|
|
|
|
|
842
|
|
285
|
10
|
|
|
|
|
295
|
unshift @expected, map {$_, $expected->{$_}} sort keys %$expected; |
|
520
|
|
|
|
|
958
|
|
286
|
|
|
|
|
|
|
} |
287
|
|
|
|
|
|
|
elsif (ref $actual && ref $expected) { |
288
|
18
|
|
|
|
|
39
|
$passed = (ref $actual eq ref $expected); |
289
|
18
|
|
|
|
|
43
|
unshift @actual, [ deref($actual) ]; |
290
|
18
|
|
|
|
|
37
|
unshift @expected, [ deref($expected) ]; |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
elsif (looks_like_number($actual) && looks_like_number($expected)) { |
293
|
1038
|
|
|
|
|
3933
|
$passed = ($actual == $expected); |
294
|
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
|
elsif (defined $actual && defined $expected) { |
296
|
44
|
|
|
|
|
210
|
$passed = ($actual eq $expected); |
297
|
|
|
|
|
|
|
} |
298
|
|
|
|
|
|
|
else { |
299
|
8
|
|
66
|
|
|
70
|
$passed = !(defined $actual || defined $expected); |
300
|
|
|
|
|
|
|
} |
301
|
|
|
|
|
|
|
} |
302
|
|
|
|
|
|
|
|
303
|
74
|
|
|
|
|
222
|
assert($passed, $msg); |
304
|
|
|
|
|
|
|
} |
305
|
|
|
|
|
|
|
|
306
|
|
|
|
|
|
|
# Checks two given arguments for inequality. |
307
|
|
|
|
|
|
|
sub refute_equal ($$;$) { |
308
|
50
|
|
|
50
|
1
|
470
|
my ($actual, $unexpected, $msg) = @_; |
309
|
50
|
|
|
|
|
90
|
$msg = message("The given values were unexpectedly equal", $msg); |
310
|
|
|
|
|
|
|
|
311
|
50
|
|
|
|
|
94
|
my @unexpected = ($unexpected); |
312
|
50
|
|
|
|
|
76
|
my @actual = ($actual); |
313
|
|
|
|
|
|
|
|
314
|
50
|
|
|
|
|
52
|
my $passed = 1; |
315
|
|
|
|
|
|
|
|
316
|
50
|
|
66
|
|
|
209
|
while ($passed && (@actual || @unexpected)) { |
|
|
|
66
|
|
|
|
|
317
|
124
|
|
|
|
|
202
|
($actual, $unexpected) = (shift(@actual), shift(@unexpected)); |
318
|
|
|
|
|
|
|
|
319
|
124
|
100
|
66
|
|
|
684
|
next if ref $actual && ref $unexpected && refaddr($actual) == refaddr($unexpected); |
|
|
|
100
|
|
|
|
|
320
|
|
|
|
|
|
|
|
321
|
118
|
100
|
66
|
|
|
150
|
if (eval { $unexpected->can('equals') }) { |
|
118
|
100
|
66
|
|
|
2814
|
|
|
|
100
|
66
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
|
|
|
|
|
322
|
8
|
|
|
|
|
23
|
$passed = $unexpected->equals($actual); |
323
|
|
|
|
|
|
|
} |
324
|
|
|
|
|
|
|
elsif (ref $actual eq 'ARRAY' && ref $unexpected eq 'ARRAY') { |
325
|
24
|
|
|
|
|
40
|
$passed = (@$actual == @$unexpected); |
326
|
24
|
|
|
|
|
40
|
unshift @actual, @$actual; |
327
|
24
|
|
|
|
|
115
|
unshift @unexpected, @$unexpected; |
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
elsif (ref $actual eq 'HASH' && ref $unexpected eq 'HASH') { |
330
|
8
|
|
|
|
|
22
|
$passed = (keys %$actual == keys %$unexpected); |
331
|
8
|
|
|
|
|
34
|
unshift @actual, map {$_, $actual->{$_}} sort keys %$actual; |
|
16
|
|
|
|
|
36
|
|
332
|
8
|
|
|
|
|
22
|
unshift @unexpected, map {$_, $unexpected->{$_}} sort keys %$unexpected; |
|
16
|
|
|
|
|
60
|
|
333
|
|
|
|
|
|
|
} |
334
|
|
|
|
|
|
|
elsif (ref $actual && ref $unexpected) { |
335
|
18
|
|
|
|
|
33
|
$passed = (ref $actual eq ref $unexpected); |
336
|
18
|
|
|
|
|
36
|
unshift @actual, [ deref($actual) ]; |
337
|
18
|
|
|
|
|
34
|
unshift @unexpected, [ deref($unexpected) ]; |
338
|
|
|
|
|
|
|
} |
339
|
|
|
|
|
|
|
elsif (looks_like_number($actual) && looks_like_number($unexpected)) { |
340
|
28
|
|
|
|
|
131
|
$passed = ($actual == $unexpected); |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
elsif (defined $actual && defined $unexpected) { |
343
|
24
|
|
|
|
|
97
|
$passed = ($actual eq $unexpected); |
344
|
|
|
|
|
|
|
} |
345
|
|
|
|
|
|
|
else { |
346
|
8
|
|
66
|
|
|
61
|
$passed = !(defined $actual || defined $unexpected); |
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
|
350
|
50
|
|
|
|
|
112
|
refute($passed, $msg); |
351
|
|
|
|
|
|
|
} |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
# Checks that the difference between $actual and $expected is less than |
354
|
|
|
|
|
|
|
# $delta. |
355
|
|
|
|
|
|
|
sub assert_in_delta ($$;$$) { |
356
|
11
|
|
|
11
|
1
|
66
|
my ($actual, $expected, $delta, $msg) = @_; |
357
|
11
|
50
|
|
|
|
28
|
$delta = 0.001 unless defined $delta; |
358
|
11
|
|
|
|
|
19
|
my $n = abs($actual - $expected); |
359
|
11
|
|
|
|
|
111
|
$msg = message("Expected $actual - $expected ($n) to be < $delta", $msg); |
360
|
11
|
|
|
|
|
36
|
assert($delta >= $n, $msg); |
361
|
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
# Checks that the difference between $actual and $expected is greater than |
364
|
|
|
|
|
|
|
# $delta. |
365
|
|
|
|
|
|
|
sub refute_in_delta ($$;$$) { |
366
|
5
|
|
|
5
|
1
|
44
|
my ($actual, $expected, $delta, $msg) = @_; |
367
|
5
|
50
|
|
|
|
12
|
$delta = 0.001 unless defined $delta; |
368
|
5
|
|
|
|
|
10
|
my $n = abs($actual - $expected); |
369
|
5
|
|
|
|
|
51
|
$msg = message("Expected $actual - $expected ($n) to be > $delta", $msg); |
370
|
5
|
|
|
|
|
15
|
refute($delta >= $n, $msg); |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
# Checks that the difference between $actual and $expected is less than |
374
|
|
|
|
|
|
|
# a given fraction of the smaller of the two numbers. |
375
|
|
|
|
|
|
|
sub assert_in_epsilon ($$;$$) { |
376
|
8
|
|
|
8
|
1
|
37
|
my ($actual, $expected, $epsilon, $msg) = @_; |
377
|
8
|
100
|
|
|
|
33
|
$epsilon = 0.001 unless defined $epsilon; |
378
|
8
|
|
|
|
|
37
|
assert_in_delta( |
379
|
|
|
|
|
|
|
$actual, |
380
|
|
|
|
|
|
|
$expected, |
381
|
|
|
|
|
|
|
min(abs($actual), abs($expected)) * $epsilon, |
382
|
|
|
|
|
|
|
$msg, |
383
|
|
|
|
|
|
|
); |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
# Checks that the difference between $actual and $expected is greater than |
387
|
|
|
|
|
|
|
# a given fraction of the smaller of the two numbers. |
388
|
|
|
|
|
|
|
sub refute_in_epsilon ($$;$$) { |
389
|
2
|
|
|
2
|
1
|
36
|
my ($actual, $expected, $epsilon, $msg) = @_; |
390
|
2
|
100
|
|
|
|
8
|
$epsilon = 0.001 unless defined $epsilon; |
391
|
2
|
|
|
|
|
14
|
refute_in_delta( |
392
|
|
|
|
|
|
|
$actual, |
393
|
|
|
|
|
|
|
$expected, |
394
|
|
|
|
|
|
|
min(abs($actual), abs($expected)) * $epsilon, |
395
|
|
|
|
|
|
|
$msg, |
396
|
|
|
|
|
|
|
); |
397
|
|
|
|
|
|
|
} |
398
|
|
|
|
|
|
|
|
399
|
|
|
|
|
|
|
# Verifies that the given $collection contains the given $obj as a member. |
400
|
10
|
|
|
10
|
0
|
274
|
sub assert_includes ($$;$) { goto &assert_contains } |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
# Verifies that the given $collection does not contain the given $obj as a |
403
|
|
|
|
|
|
|
# member. |
404
|
10
|
|
|
10
|
0
|
206
|
sub refute_includes ($$;$) { goto &refute_contains } |
405
|
|
|
|
|
|
|
|
406
|
|
|
|
|
|
|
# Validates that the given object is an instance of $type. |
407
|
|
|
|
|
|
|
sub assert_instance_of ($$;$) { |
408
|
14
|
|
|
14
|
1
|
69
|
my ($obj, $type, $msg) = @_; |
409
|
14
|
|
|
|
|
20
|
$msg = message("Expected @{[inspect($obj)]} to be an instance of $type, not @{[ref $obj]}", $msg); |
|
14
|
|
|
|
|
31
|
|
|
14
|
|
|
|
|
559
|
|
410
|
14
|
|
|
|
|
65
|
assert(ref $obj eq $type, $msg); |
411
|
|
|
|
|
|
|
} |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
# Validates that $obj inherits from $type. |
414
|
|
|
|
|
|
|
sub assert_is_a($$;$) { |
415
|
12
|
|
|
12
|
1
|
106
|
my ($obj, $type, $msg) = @_; |
416
|
12
|
|
|
|
|
15
|
$msg = message("Expected @{[inspect($obj)]} to inherit from $type", $msg); |
|
12
|
|
|
|
|
20
|
|
417
|
12
|
|
|
|
|
78
|
assert($obj->isa($type), $msg); |
418
|
|
|
|
|
|
|
} |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
# Validates that $obj inherits from $type. |
421
|
6
|
|
|
6
|
0
|
95
|
sub assert_isa { goto &assert_is_a } |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
# Validates that the given $string matches the given $pattern. |
424
|
|
|
|
|
|
|
sub assert_match ($$;$) { |
425
|
2
|
|
|
2
|
1
|
48
|
my ($string, $pattern, $msg) = @_; |
426
|
2
|
|
|
|
|
8
|
$msg = message("Expected qr/$pattern/ to match against @{[inspect($string)]}", $msg); |
|
2
|
|
|
|
|
6
|
|
427
|
2
|
|
|
|
|
24
|
assert($string =~ $pattern, $msg); |
428
|
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
# Validates that the given $string does not match the given $pattern. |
431
|
|
|
|
|
|
|
sub refute_match ($$;$) { |
432
|
2
|
|
|
2
|
1
|
30
|
my ($string, $pattern, $msg) = @_; |
433
|
2
|
|
|
|
|
6
|
$msg = message("Expected qr/$pattern/ to fail to match against @{[inspect($string)]}", $msg); |
|
2
|
|
|
|
|
4
|
|
434
|
2
|
|
|
|
|
13
|
refute($string =~ $pattern, $msg); |
435
|
|
|
|
|
|
|
} |
436
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
# Verifies that the given $obj is capable of responding to the given |
438
|
|
|
|
|
|
|
# $method name. |
439
|
2
|
|
|
2
|
0
|
39
|
sub assert_responds_to ($$;$) { goto &assert_can } |
440
|
|
|
|
|
|
|
|
441
|
|
|
|
|
|
|
# Verifies that the given $obj is *not* capable of responding to the given |
442
|
|
|
|
|
|
|
# $method name. |
443
|
2
|
|
|
2
|
0
|
56
|
sub refute_responds_to ($$;$) { goto &refute_can } |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
# Validates that the given $obj is undefined. |
446
|
|
|
|
|
|
|
sub assert_undef ($;$) { |
447
|
12
|
|
|
12
|
1
|
108
|
my ($obj, $msg) = @_; |
448
|
12
|
|
|
|
|
19
|
$msg = message("Expected @{[inspect($obj)]} to be undefined", $msg); |
|
12
|
|
|
|
|
25
|
|
449
|
12
|
|
|
|
|
52
|
refute(defined $obj, $msg); |
450
|
|
|
|
|
|
|
} |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
# Validates that the given $obj is not undefined. |
453
|
6
|
|
|
6
|
0
|
86
|
sub refute_undef ($;$) { goto &assert_defined } |
454
|
|
|
|
|
|
|
|
455
|
|
|
|
|
|
|
# Allows the current test to be bypassed with an indeterminate status. |
456
|
|
|
|
|
|
|
sub skip (;$) { |
457
|
1
|
|
|
1
|
1
|
5
|
my ($msg) = @_; |
458
|
1
|
50
|
|
|
|
4
|
$msg = 'Test skipped; no message given.' unless defined $msg; |
459
|
1
|
50
|
|
|
|
4
|
$msg = $msg->() if ref $msg eq 'CODE'; |
460
|
1
|
|
|
|
|
8
|
Test::Mini::Exception::Skip->throw( |
461
|
|
|
|
|
|
|
message => $msg, |
462
|
|
|
|
|
|
|
ignore_package => [__PACKAGE__], |
463
|
|
|
|
|
|
|
); |
464
|
|
|
|
|
|
|
} |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
# Causes the current test to exit immediately with a failing status. |
467
|
|
|
|
|
|
|
sub flunk (;$) { |
468
|
0
|
|
|
0
|
1
|
|
my ($msg) = @_; |
469
|
0
|
0
|
|
|
|
|
$msg = 'Epic failure' unless defined $msg; |
470
|
0
|
|
|
|
|
|
assert(0, $msg); |
471
|
|
|
|
|
|
|
} |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
1; |
474
|
|
|
|
|
|
|
|
475
|
|
|
|
|
|
|
__END__ |