File Coverage

lib/Test/Assert.pm
Criterion Covered Total %
statement 260 282 92.2
branch 213 240 88.7
condition 55 77 71.4
subroutine 39 42 92.8
pod 19 19 100.0
total 586 660 88.7


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -c
2              
3             package Test::Assert;
4              
5             =head1 NAME
6              
7             Test::Assert - Assertion methods for those who like JUnit.
8              
9             =head1 SYNOPSIS
10              
11             # Use as imported methods
12             #
13             package My::Test;
14              
15             use Test::Assert ':all';
16              
17             assert_true(1, "pass");
18             assert_true(0, "fail");
19              
20             use Test::More;
21             assert_test(sub { require_ok($module) });
22              
23             # Use for debugging purposes
24             # Assertions are compiled only if Test::Assert was used
25             # from the main package.
26             #
27             package My::Package;
28              
29             use Test::Assert ':assert';
30              
31             my $state = do_something();
32             assert_true($state >= 1 && $state <=2) if ASSERT;
33             if ($state == 1) {
34             # 1st state
35             do_foo();
36             } elsif ($state == 2) {
37             # 2nd and last state
38             do_bar();
39             }
40              
41             my $a = get_a();
42             my $b = get_b();
43             assert_num_not_equals(0, $b) if ASSERT;
44             my $c = $a / $b;
45              
46             # Clean the namespace
47             no Test::Assert;
48              
49             # From command line
50             $ perl -MTest::Assert script.pl # sets Test::Assert::ASSERT to 1
51              
52             =head1 DESCRIPTION
53              
54             This class provides a set of assertion methods useful for writing tests. The
55             API is based on JUnit4 and L and the methods die on failure.
56              
57             These assertion methods might be not useful for common L-based
58             (L, L, etc.) test units.
59              
60             The assertion methods can be used in class which is derived from
61             C or used as standard Perl functions after importing them into
62             user's namespace.
63              
64             C can also wrap standard L, L or other
65             L-based tests.
66              
67             The assertions can be also used for run-time checking.
68              
69             =for readme stop
70              
71             =cut
72              
73 4     4   119732 use 5.006;
  4         14  
  4         187  
74              
75 4     4   21 use strict;
  4         17  
  4         143  
76 4     4   27 use warnings;
  4         16  
  4         247  
77              
78             our $VERSION = '0.0504';
79              
80              
81             use Exception::Base (
82 4         37 'ignore_class' => [ __PACKAGE__, 'Test::Builder' ],
83             'Exception::Assertion',
84 4     4   5605 );
  4         58177  
85              
86              
87             # TRUE and FALSE
88 4     4   10044 use constant::boolean;
  4         1353  
  4         23  
89              
90              
91             # Debug mode is disabled by default
92             ## no critic (ProhibitConstantPragma)
93 4     4   175 use constant ASSERT => FALSE;
  4         7  
  4         269  
94              
95              
96             # Export ASSERT flag, all assert_* methods and fail method
97 4     4   3878 use Symbol::Util qw( export_package unexport_package stash );
  4         14995  
  4         38  
98              
99              
100             # Variable required for assert_deep_equal
101             my $DNE = bless [], 'Test::Assert::Does::Not::Exist';
102              
103              
104             # Enable debug mode
105             sub import {
106 8     8   23099 my ($package, @names) = @_;
107 8         22 my $caller = caller();
108              
109             # Enable only if called from main
110 8 100       38 if ($caller eq 'main') {
111 2         9 undef *ASSERT;
112 2         7 *ASSERT = sub () { TRUE; };
113             };
114              
115 8         17 my @export_ok = ( 'ASSERT', grep { /^(assert_|fail)/ } keys %{ stash(__PACKAGE__) } );
  251         578  
  8         32  
116 160         321 my %export_tags = (
117             all => [ @export_ok ],
118 8         53 assert => [ grep { /^(assert_|ASSERT$)/ } @export_ok ],
119             );
120              
121 8         63 return export_package($caller, $package, {
122             OK => \@export_ok,
123             TAGS => \%export_tags,
124             }, @names);
125             };
126              
127              
128             # Disable debug mode
129             sub unimport {
130 3     3   160 my ($package, @names) = @_;
131 3         9 my $caller = caller();
132              
133             # Disable only if called from main
134 3 100       196 if ($caller eq 'main') {
135 1         9 undef *ASSERT;
136 1         4 *ASSERT = sub () { FALSE; };
137             };
138              
139 3         15 return unexport_package($caller, $package);
140             };
141              
142              
143             ## no critic (ProhibitNegativeExpressionsInUnlessAndUntilConditions)
144             ## no critic (ProhibitSubroutinePrototypes)
145             ## no critic (RequireArgUnpacking)
146             ## no critic (RequireCheckingReturnValueOfEval)
147              
148             # Fails a test with the given name.
149             sub fail (;$$) {
150             # check if called as function
151 123 100   123 1 253 my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__;
152 123         293 my ($message, $reason) = @_;
153              
154 123         924 Exception::Assertion->throw(
155             message => $message,
156             reason => $reason,
157             );
158              
159 0         0 assert_false("Should never occured") if ASSERT;
160 0         0 return FALSE;
161             };
162              
163              
164             # Asserts that a condition is true.
165             sub assert_true ($;$) {
166             # check if called as function
167 8 100   8 1 85 my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__;
168 8         12 my ($boolean, $message) = @_;
169              
170 8 100       23 $self->fail($message, "Expected true value, got undef") unless defined $boolean;
171 6 100       17 $self->fail($message, "Expected true value, got '$boolean'") unless $boolean;
172 4         7 return TRUE;
173             };
174              
175              
176             # Asserts that a condition is false.
177             sub assert_false ($;$) {
178             # check if called as function
179 8 100   8 1 135 my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__;
180 8         12 my ($boolean, $message) = @_;
181              
182 8 100       25 $self->fail($message, "Expected false value, got '$boolean'") unless not $boolean;
183 5         11 return TRUE;
184             };
185              
186              
187             # Asserts that a value is null.
188             sub assert_null ($;$) {
189             # check if called as function
190 8 100   8 1 75 my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__;
191 8         13 my ($value, $message) = @_;
192              
193 8 100       29 $self->fail($message, "'$value' is defined") unless not defined $value;
194 3         6 return TRUE;
195             };
196              
197              
198             # Asserts that a value is not null.
199             sub assert_not_null ($;$) {
200             # check if called as function
201 9 100   9 1 251 my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__;
202 9         16 my ($value, $message) = @_;
203              
204 9 100       22 $self->fail($message, 'undef unexpected') unless defined $value;
205 7         14 return TRUE;
206             };
207              
208              
209             # Assert that two values are equal
210             sub assert_equals ($$;$) {
211             # check if called as function
212 40 100   40 1 823 my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__;
213 40         75 my ($value1, $value2, $message) = @_;
214              
215 40 100 66     150 return TRUE if (not defined $value1 and not defined $value2);
216 37 100       367 $self->fail(
217             $message, 'Expected value was undef; should be using assert_null?'
218             ) unless defined $value1;
219 36 100       262 $self->fail($message, "Expected '$value1', got undef") unless defined $value2;
220 34 100 100     409 if ($value1 =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/ and
221             $value2 =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/)
222             {
223 4     4   5061 no warnings 'numeric';
  4         15  
  4         1285  
224 15 100       72 $self->fail($message, 'Expected ' . (0+$value1) . ', got ' . (0+$value2)) unless $value1 == $value2;
225             }
226             else {
227 19 100       62 $self->fail($message, "Expected '$value1', got '$value2'") unless $value1 eq $value2;
228             };
229 21         66 return TRUE;
230             };
231              
232              
233             # Assert that two values are not equal
234             sub assert_not_equals ($$;$) {
235             # check if called as function
236 31 100   31 1 5637 my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__;
237 31         59 my ($value1, $value2, $message) = @_;
238              
239 31 100 66     86 if (not defined $value1 and not defined $value2) {
240 2         8 $self->fail($message, 'Both values were undefined');
241             };
242 29 100 75     145 return TRUE if (not defined $value1 xor not defined $value2);
243 25 100 100     250 if ($value1 =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/ and
244             $value2 =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/)
245             {
246 4     4   24 no warnings 'numeric';
  4         14  
  4         793  
247 16 100       101 $self->fail($message, (0+$value1) . ' and ' . (0+$value2) . ' should differ') unless $value1 != $value2;
248             }
249             else {
250 9 100       32 $self->fail($message, "'$value1' and '$value2' should differ") unless $value1 ne $value2;
251             };
252 14         32 return TRUE;
253             };
254              
255              
256             # Assert that two values are numerically equal
257             sub assert_num_equals ($$;$) {
258             # check if called as function
259 20 100   20 1 121 my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__;
260              
261 20         37 my ($value1, $value2, $message) = @_;
262 20 100 66     50 return TRUE if (not defined $value1 and not defined $value2);
263 4     4   24 no warnings 'numeric';
  4         9  
  4         949  
264 17 100       34 $self->fail($message, 'Expected undef, got ' . (0+$value2)) if not defined $value1;
265 15 100       28 $self->fail($message, 'Expected ' . (0+$value1) . ', got undef') if not defined $value2;
266 14 100       69 $self->fail($message, 'Expected ' . (0+$value1) . ', got ' . (0+$value2)) unless $value1 == $value2;
267 13         27 return TRUE;
268             };
269              
270              
271             # Assert that two values are numerically not equal
272             sub assert_num_not_equals ($$;$) {
273             # check if called as function
274 18 100   18 1 201 my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__;
275              
276 18         35 my ($value1, $value2, $message) = @_;
277 18 100 66     43 if (not defined $value1 and not defined $value2) {
278 1         4 $self->fail($message, 'Both values were undefined');
279             };
280 17 100 75     79 return TRUE if (not defined $value1 xor not defined $value2);
281 4     4   24 no warnings 'numeric';
  4         8  
  4         19768  
282 15 100       88 $self->fail($message, (0+$value1) . ' and ' . (0+$value2) . ' should differ') unless $value1 != $value2;
283 3         6 return TRUE;
284             };
285              
286              
287             # Assert that two strings are equal
288             sub assert_str_equals ($$;$) {
289             # check if called as function
290 13 100   13 1 147 my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__;
291              
292 13         23 my ($value1, $value2, $message) = @_;
293 13 100 66     41 return TRUE if (not defined $value1 and not defined $value2);
294 10 100       22 $self->fail(
295             $message, 'Expected value was undef; should be using assert_null?'
296             ) unless defined $value1;
297 9 100       18 $self->fail($message, "Expected '$value1', got undef") unless defined $value2;
298 8 100       34 $self->fail($message, "Expected '$value1', got '$value2'") unless "$value1" eq "$value2";
299 4         11 return TRUE;
300             };
301              
302              
303             # Assert that two strings are not equal
304             sub assert_str_not_equals ($$;$) {
305             # check if called as function
306 13 100   13 1 137 my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__;
307              
308 13         24 my ($value1, $value2, $message) = @_;
309 13 100 66     38 if (not defined $value1 and not defined $value2) {
310 1         4 $self->fail($message, 'Both values were undefined');
311             };
312 12 100 75     59 return TRUE if (not defined $value1 xor not defined $value2);
313 8 100       35 $self->fail($message, "'$value1' and '$value2' should differ") unless "$value1" ne "$value2";
314 4         10 return TRUE;
315             };
316              
317              
318             # Assert that string matches regexp
319             sub assert_matches ($$;$) {
320             # check if called as function
321 9 100   9 1 1244 my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__;
322              
323 9         17 my ($regexp, $value, $message) = @_;
324 9 100       33 $self->fail(
325             $message, 'Expected value was undef; should be using assert_null?'
326             ) unless defined $regexp;
327 8 100       21 $self->fail(
328             $message, 'Argument 1 to assert_matches() must be a regexp'
329             ) unless ref $regexp eq 'Regexp';
330 7 100       19 $self->fail($message, "Expected /$regexp/, got undef") unless defined $value;
331 6 100       38 $self->fail($message, "'$value' didn't match /$regexp/") unless $value =~ $regexp;
332 5         22 return TRUE;
333             };
334              
335              
336             # Assert that string matches regexp
337             sub assert_not_matches ($$;$) {
338             # check if called as function
339 8 100   8 1 109 my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__;
340              
341 8         13 my ($regexp, $value, $message) = @_;
342 8 100       21 $self->fail(
343             $message, 'Expected value was undef; should be using assert_null?'
344             ) unless defined $regexp;
345 6 100       15 return TRUE if not defined $value;
346 3 100       24 $self->fail(
347             $message, 'Argument 1 to assert_not_matches() must be a regexp'
348             ) unless ref $regexp eq 'Regexp';
349 2 100       14 $self->fail($message, "'$value' matched /$regexp/") unless $value !~ $regexp;
350 1         4 return TRUE;
351             };
352              
353              
354             # Assert that data structures are deeply equal
355             sub assert_deep_equals ($$;$) {
356             # check if called as function
357 37 100   37 1 13043 my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__;
358              
359 37         80 my ($value1, $value2, $message) = @_;
360 37 100 100     146 $self->fail($message, 'Both arguments were not references') unless ref $value1 or ref $value2;
361 32 100       81 $self->fail($message, 'Argument 1 to assert_deep_equals() must be a reference') unless ref $value1;
362 31 100       147 $self->fail($message, 'Argument 2 to assert_deep_equals() must be a reference') unless ref $value2;
363              
364 30         54 my $data_stack = [];
365 30         51 my $seen_refs = {};
366              
367 30 100       106 $self->fail(
368             $message, $self->_format_stack($data_stack)
369             ) unless $self->_deep_check($value1, $value2, $data_stack, $seen_refs);
370              
371 15         68 return TRUE;
372             };
373              
374              
375             # Assert that data structures are deeply equal
376             sub assert_deep_not_equals ($$;$) {
377             # check if called as function
378 15 100   15 1 272 my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__;
379              
380 15         33 my ($value1, $value2, $message) = @_;
381 15 100 100     57 $self->fail($message, 'Both arguments were not references') unless ref $value1 or ref $value2;
382 12 100       26 $self->fail($message, 'Argument 1 to assert_deep_equals() must be a reference') unless ref $value1;
383 11 100       22 $self->fail($message, 'Argument 2 to assert_deep_equals() must be a reference') unless ref $value2;
384              
385 10         14 my $data_stack = [];
386 10         14 my $seen_refs = {};
387              
388 10 100       35 $self->fail(
389             $message, 'Both structures should differ'
390             ) unless not $self->_deep_check($value1, $value2, $data_stack, $seen_refs);
391              
392 6         35 return TRUE;
393             };
394              
395              
396             # Assert that object is a class
397             sub assert_isa ($$;$) {
398             # check if called as function
399 11 100   11 1 333 my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__;
400              
401 11         24 my ($class, $value, $message) = @_;
402              
403 11 100       31 $self->fail(
404             $message, 'Class name was undef; should be using assert_null?'
405             ) unless defined $class;
406 10 100       24 $self->fail($message, "Expected '$class' object or class, got undef") unless defined $value;
407 9 100       20 if (not __isa($value, $class)) {
408 2 100       12 $self->fail($message, "Expected '$class' object or class, got '" . ref($value) . "' reference") if ref $value;
409 1         6 $self->fail($message, "Expected '$class' object or class, got '$value' value");
410             };
411 7         26 return TRUE;
412             };
413              
414              
415             # Assert that object is not a class
416             sub assert_not_isa ($$;$) {
417             # check if called as function
418 7 100   7 1 460 my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__;
419              
420 7         14 my ($class, $value, $message) = @_;
421              
422 7 100       22 $self->fail(
423             $message, 'Class name was undef; should be using assert_null?'
424             ) unless defined $class;
425 6 100       12 if (__isa($value, $class)) {
426 2         18 $self->fail($message, "'$value' is a '$class' object or class");
427             };
428 4         11 return TRUE;
429             };
430              
431              
432             # Assert that code throws an exception
433             sub assert_raises ($&;$) {
434             # check if called as function
435 189 100   189 1 36150 my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__;
436              
437 189         413 my ($expected, $code, $message) = @_;
438              
439 189         261 eval {
440 189         2971 $code->();
441             };
442 189 100       54021 if ($@) {
443 187         1388 my $e = $@;
444 187 100 100     1053 if (ref $e and __isa($e, 'Exception::Base')) {
445 127 100       510 return TRUE if $e->matches($expected);
446             }
447             else {
448 60 100       163 if (ref $expected eq 'Regexp') {
    100          
    50          
449 53 100       562 return TRUE if "$e" =~ $expected;
450             }
451             elsif (ref $expected eq 'ARRAY') {
452 3 100       5 return TRUE if grep { __isa($e, $_) } @{ $expected };
  3         8  
  3         6  
453             }
454             elsif (not ref $expected) {
455 4         10 my $caught_message = "$e";
456 4         14 while ($caught_message =~ s/\t\.\.\.propagated at (?!.*\bat\b.*).* line \d+( thread \d+)?\.\n$//s) { }
457 4         35 $caught_message =~ s/( at (?!.*\bat\b.*).* line \d+( thread \d+)?\.)?\n$//s;
458 4 100       16 return TRUE if $caught_message eq $expected;
459             };
460             };
461             # Rethrow an exception
462             ## no critic (RequireCarping)
463 5         92 die $e;
464             }
465             else {
466 2         6 $self->fail(
467             $message, 'Expected exception was not raised'
468             );
469             };
470 0         0 return TRUE;
471             };
472              
473              
474             # Assert that Test::Builder method is ok
475             sub assert_test (&;$) {
476             # check if called as function
477 0 0   0 1 0 my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__;
478              
479 0         0 my ($code, $message) = @_;
480              
481 0         0 my $diag_message = '';
482 0         0 my $ok_message = '';
483 0         0 my $ok_return = TRUE;
484              
485 4     4   38 no warnings 'once', 'redefine';
  4         8  
  4         7441  
486             local *Test::Builder::diag = sub {
487 0 0   0   0 $diag_message .= $_[1] if defined $_[1];
488 0         0 };
489             local *Test::Builder::ok = sub {
490 0 0   0   0 $ok_message .= $_[2] if defined $_[2];
491 0         0 return $ok_return = $_[1];
492 0         0 };
493              
494 0         0 $code->();
495 0 0       0 if (not $ok_return) {
496 0 0 0     0 my $new_message = (defined $message ? $message : '')
    0 0        
    0          
    0          
    0          
497             . (defined $message && $message ne '' && $ok_message ne '' ? ': ' : '')
498             . ($ok_message =~ /\n/s ? "\n" : '')
499             . $ok_message
500             . ($ok_message ne '' && $diag_message ne '' ? ': ' : '')
501             . ($diag_message =~ /\n/s ? "\n" : '')
502             . $diag_message;
503 0 0       0 $self->fail(
504             $new_message, 'assert_test failed'
505             ) unless $ok_return;
506             };
507 0         0 return TRUE;
508             };
509              
510              
511             # Checks if deep structures are equal
512             sub _deep_check {
513 193     193   380 my ($self, $e1, $e2, $data_stack, $seen_refs) = @_;
514              
515 193 100 66     1137 if ( ! defined $e1 || ! defined $e2 ) {
516 7 100 66     33 return TRUE if !defined $e1 && !defined $e2;
517 4         13 push @$data_stack, { vals => [$e1, $e2] };
518 4         14 return FALSE;
519             };
520              
521 186 100       1361 return TRUE if $e1 eq $e2;
522              
523 87 100 100     455 if ( ref $e1 && ref $e2 ) {
524 73         138 my $e2_ref = "$e2";
525 73 100 66     229 return TRUE if defined $seen_refs->{$e1} && $seen_refs->{$e1} eq $e2_ref;
526 69         217 $seen_refs->{$e1} = $e2_ref;
527             };
528              
529 83 100 100     611 if (ref $e1 eq 'ARRAY' and ref $e2 eq 'ARRAY') {
    100 66        
    50 33        
    100 66        
530 34         501 return $self->_eq_array($e1, $e2, $data_stack, $seen_refs);
531             }
532             elsif (ref $e1 eq 'HASH' and ref $e2 eq 'HASH') {
533 29         83 return $self->_eq_hash($e1, $e2, $data_stack, $seen_refs);
534             }
535             elsif (ref $e1 eq 'REF' and ref $e2 eq 'REF') {
536 0         0 push @$data_stack, { type => 'REF', vals => [$e1, $e2] };
537 0         0 my $ok = $self->_deep_check($$e1, $$e2, $data_stack, $seen_refs);
538 0 0       0 pop @$data_stack if $ok;
539 0         0 return $ok;
540             }
541             elsif (ref $e1 eq 'SCALAR' and ref $e2 eq 'SCALAR') {
542 3         8 push @$data_stack, { type => 'REF', vals => [$e1, $e2] };
543 3         10 return $self->_deep_check($$e1, $$e2, $data_stack, $seen_refs);
544             }
545             else {
546 17         69 push @$data_stack, { vals => [$e1, $e2] };
547             };
548              
549 17         52 return FALSE;
550             };
551              
552              
553             # Checks if arrays are equal
554             sub _eq_array {
555 34     34   59 my ($self, $a1, $a2, $data_stack, $seen_refs) = @_;
556              
557 34 50       85 return TRUE if $a1 eq $a2;
558              
559 34         49 my $ok = TRUE;
560 34 100       83 my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
561              
562 34         82 foreach (0..$max) {
563 104 100       212 my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
564 104 100       392 my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
565              
566 104         461 push @$data_stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
567 104         296 $ok = $self->_deep_check($e1, $e2, $data_stack, $seen_refs);
568 104 100       224 pop @$data_stack if $ok;
569              
570 104 100       380 last unless $ok;
571             };
572              
573 34         149 return $ok;
574             };
575              
576              
577             # Checks if hashes are equal
578             sub _eq_hash {
579 29     29   55 my ($self, $a1, $a2, $data_stack, $seen_refs) = @_;
580              
581 29 50       68 return TRUE if $a1 eq $a2;
582              
583 29         41 my $ok = TRUE;
584 29 100       182 my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
585 29         68 foreach my $k (keys %$bigger) {
586 46 50       110 my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
587 46 100       257 my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
588              
589 46         175 push @$data_stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
590 46         129 $ok = $self->_deep_check($e1, $e2, $data_stack, $seen_refs);
591 46 100       200 pop @$data_stack if $ok;
592              
593 46 100       149 last unless $ok;
594             };
595              
596 29         124 return $ok;
597             };
598              
599              
600             # Dumps the differences for deep structures
601             sub _format_stack {
602 15     15   23 my ($self, $data_stack) = @_;
603              
604 15         18 my $var = '$FOO';
605 15         78 my $did_arrow = 0;
606 15         29 foreach my $entry (@$data_stack) {
607 36   100     120 my $type = $entry->{type} || '';
608 36         44 my $idx = $entry->{'idx'};
609 36 100       150 if ($type eq 'HASH') {
    100          
    100          
610 9 100       23 $var .= "->" unless $did_arrow++;
611 9         20 $var .= "{$idx}";
612             }
613             elsif ($type eq 'ARRAY') {
614 10 100       86 $var .= "->" unless $did_arrow++;
615 10         23 $var .= "[$idx]";
616             }
617             elsif ($type eq 'REF') {
618 2         4 $var = "\${$var}";
619             };
620             };
621              
622 15         25 my @vals = @{$data_stack->[-1]{vals}}[0,1];
  15         303  
623              
624 15         21 my @vars = ();
625 15         193 ($vars[0] = $var) =~ s/\$FOO/ \$a/;
626 15         135 ($vars[1] = $var) =~ s/\$FOO/ \$b/;
627              
628 15         21 my $out = "Structures begin differing at:\n";
629 15         36 foreach my $idx (0..$#vals) {
630 30         41 my $val = $vals[$idx];
631 30 100       220 $vals[$idx] = !defined $val ? 'undef' :
    100          
632             $val eq $DNE ? 'Does not exist'
633             : "'$val'";
634             };
635              
636 15         41 $out .= "$vars[0] = $vals[0]\n";
637 15         29 $out .= "$vars[1] = $vals[1]";
638              
639 15         64 return $out;
640             };
641              
642              
643             # Better, safe "isa" function
644             sub __isa {
645 715     715   2017 my ($object, $class) = @_;
646 715         1635 local $@ = '';
647 715         3084 local $SIG{__DIE__} = '';
648 715         1166 return eval { $object->isa($class) };
  715         8597  
649             };
650              
651              
652 4     4   45 no constant::boolean;
  4         7  
  4         43  
653 4     4   2641 no Symbol::Util;
  4         10  
  4         805  
654              
655              
656             1;
657              
658              
659             =begin umlwiki
660              
661             = Component Diagram =
662              
663             [ Test::Assert |
664             [Test::Assert {=}]
665             [Exception::Assertion {=}] ]
666              
667             = Class Diagram =
668              
669             [ <>
670             Test::Assert
671             ----------------------------------------------------------------------------------
672             ----------------------------------------------------------------------------------
673             fail( message : Str = undef, reason : Str = undef )
674             assert_true( boolean : Bool, message : Str = undef )
675             assert_false( boolean : Bool, message : Str = undef )
676             assert_null( value : Any, message : Str = undef )
677             assert_not_null( value : Any, message : Str = undef )
678             assert_equals( value1 : Defined, value2 : Defined, message : Str = undef )
679             assert_not_equals( value1 : Defined, value2 : Defined, message : Str = undef )
680             assert_num_equals( value1 : Defined, value2 : Defined, message : Str = undef )
681             assert_num_not_equals( value1 : Defined, value2 : Defined, message : Str = undef )
682             assert_str_equals( value1 : Defined, value2 : Defined, message : Str = undef )
683             assert_str_not_equals( value1 : Defined, value2 : Defined, message : Str = undef )
684             assert_matches( regexp : RegexpRef, value : Str, message : Str = undef )
685             assert_not_matches( regexp : RegexpRef, value : Str, message : Str = undef )
686             assert_deep_equals( value1 : Ref, value2 : Ref, message : Str = undef )
687             assert_deep_not_equals( value1 : Ref, value2 : Ref, message : Str = undef )
688             assert_isa( class : Str, object : Defined, message : Str = undef )
689             assert_not_isa( class : Str, object : Defined, message : Str = undef )
690             assert_raises( expected : Any, code : CodeRef, message : Str = undef )
691             assert_test( code : CodeRef, message : Str = undef )
692             <> ASSERT() : Bool ]
693              
694             [Test::Assert] ---> <> [Exception::Assertion]
695              
696             [Exception::Assertion] ---|> [Exception::Base]
697              
698             =end umlwiki
699              
700             =head1 EXCEPTIONS
701              
702             =over
703              
704             =item Exception::Assertion
705              
706             Thrown whether an assertion failed.
707              
708             =back
709              
710             =head1 USAGE
711              
712             By default, the class does not export its symbols.
713              
714             =over
715              
716             =item use Test::Assert;
717              
718             Enables debug mode if it is used in C
package.
719              
720             package main;
721             use Test::Assert; # Test::Assert::ASSERT is set to TRUE
722              
723             $ perl -MTest::Assert script.pl # ditto
724              
725             =item use Test::Assert 'assert_true', 'fail', ...;
726              
727             Imports some methods.
728              
729             =item use Test::Assert ':all';
730              
731             Imports all C methods, C method and C constant.
732              
733             =item use Test::Assert ':assert';
734              
735             Imports all C methods and C constant.
736              
737             =item no Test::Assert;
738              
739             Disables debug mode if it is used in C
package.
740              
741             =back
742              
743             =head1 CONSTANTS
744              
745             =over
746              
747             =item ASSERT
748              
749             This constant is set to true value if C module is used from
750             C
package. It allows to enable debug mode globally from command line.
751             The debug mode is disabled by default.
752              
753             package My::Test;
754             use Test::Assert ':assert';
755             assert_true( 0 ) if ASSERT; # fails only if debug mode is enabled
756              
757             $ perl -MTest::Assert script.pl # enable debug mode
758              
759             =back
760              
761             =head1 METHODS
762              
763             =over
764              
765             =item fail( I : Str = undef, I : Str = undef )
766              
767             Immediate fail the test. The L object will have set
768             I and I attribute based on arguments.
769              
770             =item assert_true( I : Bool, I : Str = undef )
771              
772             Checks if I expression returns true value.
773              
774             =item assert_false( I : Bool, I : Str = undef )
775              
776             Checks if I expression returns false value.
777              
778             =item assert_null( I : Any, I : Str = undef )
779              
780             =item assert_not_null( I : Any, I : Str = undef )
781              
782             Checks if I is defined or not defined.
783              
784             =item assert_equals( I : Defined, I : Defined, I : Str = undef )
785              
786             =item assert_not_equals( I : Defined, I : Defined, I : Str = undef )
787              
788             Checks if I and I are equals or not equals. If I and
789             I look like numbers then they are compared with '==' operator,
790             otherwise the string 'eq' operator is used.
791              
792             =item assert_num_equals( I : Defined, I : Defined, I : Str = undef )
793              
794             =item assert_num_not_equals( I : Defined, I : Defined, I : Str = undef )
795              
796             Force numeric comparation.
797              
798             =item assert_str_equals( I : Defined, I : Defined, I : Str = undef )
799              
800             =item assert_str_not_equals( I : Defined, I : Defined, I : Str = undef )
801              
802             Force string comparation.
803              
804             =item assert_matches( I : RegexpRef, I : Str, I : Str = undef )
805              
806             =item assert_not_matches( I : RegexpRef, I : Str, I : Str = undef )
807              
808             Checks if I matches I regexp.
809              
810             =item assert_deep_equals( I : Ref, I : Ref, I : Str = undef )
811              
812             =item assert_deep_not_equals( I : Ref, I : Ref, I : Str = undef )
813              
814             Checks if reference I is a deep copy of reference I or not.
815             The references can be deep structure. If they are different, the message will
816             display the place where they start differing.
817              
818             =item assert_isa( I : Str, I : Defined, I : Str = undef )
819              
820             =item assert_not_isa( I : Str, I : Defined, I : Str = undef )
821              
822             Checks if I is a I or not.
823              
824             assert_isa( 'My::Class', $obj );
825              
826             =item assert_raises( I : Any, I : CodeRef, I : Str = undef )
827              
828             Runs the I and checks if it raises the I exception.
829              
830             If raised exception is an L object, the assertion passes if
831             the exception C I argument (via
832             C-Ematches> method).
833              
834             If raised exception is not an L object, several conditions
835             are checked. If I argument is a string or array reference, the
836             assertion passes if the raised exception is a given class. If the argument is
837             a regexp, the string representation of exception is matched against regexp.
838              
839             use Test::Assert 'assert_raises';
840              
841             assert_raises( 'foo', sub { die 'foo' } );
842             assert_raises( ['Exception::Base'], sub { Exception::Base->throw } );
843              
844             =item assert_test( I : CodeRef, I : Str = undef )
845              
846             Wraps L based test function and throws L
847             if the test is failed. The plan test have to be disabled manually. The
848             L module imports the C method by default which conflicts
849             with C C method.
850              
851             use Test::Assert ':all';
852             use Test::More ignore => [ '!fail' ];
853              
854             Test::Builder->new->no_plan;
855             Test::Builder->new->no_ending(1);
856              
857             assert_test( sub { cmp_ok($got, '==', $expected, $test_name) } );
858              
859             =back
860              
861             =head1 SEE ALSO
862              
863             L, L.
864              
865             =head1 BUGS
866              
867             If you find the bug or want to implement new features, please report it at
868             L
869              
870             =for readme continue
871              
872             =head1 AUTHOR
873              
874             Piotr Roszatycki
875              
876             =head1 COPYRIGHT
877              
878             Copyright (C) 2008, 2009 by Piotr Roszatycki .
879              
880             This program is free software; you can redistribute it and/or modify it
881             under the same terms as Perl itself.
882              
883             See L