File Coverage

blib/lib/Test/Mini/Assertions.pm
Criterion Covered Total %
statement 244 247 98.7
branch 72 82 87.8
condition 54 74 72.9
subroutine 49 50 98.0
pod 25 34 73.5
total 444 487 91.1


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__