File Coverage

blib/lib/Test/Arrow.pm
Criterion Covered Total %
statement 335 420 79.7
branch 111 196 56.6
condition 30 65 46.1
subroutine 66 69 95.6
pod 34 34 100.0
total 576 784 73.4


line stmt bran cond sub pod time code
1             package Test::Arrow;
2 21     21   8967 use strict;
  21         132  
  21         564  
3 21     21   88 use warnings;
  21         30  
  21         461  
4 21     21   9944 use Test::Builder::Module;
  21         1158964  
  21         123  
5 21     21   10072 use Test::Name::FromLine;
  21         669308  
  21         684  
6 21     21   9090 use Text::MatchedPosition;
  21         21318  
  21         3723  
7              
8             our $VERSION = '0.20';
9              
10             our @ISA = qw/Test::Builder::Module/;
11              
12             sub _carp {
13 1     1   15 my ($pkg, $file, $line) = caller;
14 1         16 return warn @_, " at $pkg, $file line $line\n";
15             }
16              
17             sub _croak {
18 4     4   17 my ($pkg, $file, $line) = caller;
19 4         41 return die @_, " at $pkg, $file line $line\n";
20             }
21              
22 31     31 1 374 sub PASS { 1 }
23 10     10 1 18 sub FAIL { 0 }
24              
25             sub import {
26 22     22   189 my $pkg = shift;
27 22         50 my %args = map { $_ => 1 } @_;
  4         14  
28              
29             {
30 22         32 my $caller = caller;
  22         101  
31 21     21   180 no strict 'refs'; ## no critic
  21         59  
  21         15795  
32 22         44 *{"${caller}::done"} = \&done;
  22         106  
33 22         40 *{"${caller}::t"} = \&t;
  22         83  
34             }
35              
36 22         117 $pkg->_import_option_no_strict(\%args);
37 22         126 $pkg->_import_option_no_warnings(\%args);
38 22         67 $pkg->_import_option_binary(\%args);
39              
40 22 100       160 if (scalar(keys %args) > 0) {
41 1         6 _croak "Wrong option: " . join(", ", keys %args);
42             }
43              
44 21 100       52 if ( _need_io_handle() ) {
45 1         7 require IO::Handle;
46 1         21 IO::Handle->import;
47             }
48             }
49              
50 20     20   28155 sub _need_io_handle { $] < 5.014000 }
51              
52             sub _import_option_no_strict {
53 22     22   72 my ($pkg, $args) = @_;
54              
55 22 100       132 my $no_strict = delete $args->{no_strict} or delete $args->{'-strict'};
56 22 100       140 if (!$no_strict) {
57 21         142 strict->import;
58             }
59             }
60              
61             sub _import_option_no_warnings {
62 22     22   52 my ($pkg, $args) = @_;
63              
64 22 100       93 my $no_warnings = delete $args->{no_warnings} or delete $args->{'-warnings'};
65 22 100       73 if (!$no_warnings) {
66 21         164 warnings->import;
67             }
68             }
69              
70             sub _import_option_binary {
71 22     22   45 my ($pkg, $args) = @_;
72              
73             my $binary = delete $args->{binary} or delete $args->{binary_mode}
74 22 50 66     251 or delete $args->{not_utf8} or delete $args->{'-utf8'} or delete $args->{'-utf'};
      33        
      33        
75 22 100       67 if (!$binary) {
76 21         160 binmode $pkg->builder->$_, ':utf8' for qw(failure_output todo_output output);
77 21         9387 require utf8;
78 21         101 utf8->import;
79             }
80             }
81              
82             sub new {
83 25     25 1 1757 my $class = shift;
84 25         67 my %args = @_;
85              
86             my $self = bless {
87 25         87 no_x => delete $args{'no_x'},
88             }, $class;
89              
90 25 100       87 if ($args{plan}) {
91 2         4 $self->plan(%{$args{plan}});
  2         9  
92             }
93              
94 24         799 $self;
95             }
96              
97             sub t {
98 6     6 1 284 return __PACKAGE__->new(@_);
99             }
100              
101 182     182   531 sub _tb { __PACKAGE__->builder }
102              
103             sub _reset {
104 106     106   185 my ($self) = @_;
105              
106 106         149 delete $self->{_name};
107 106         128 delete $self->{_expected};
108 106         129 delete $self->{_got};
109              
110 106         136 $self;
111             }
112              
113 2     2 1 70 sub pass { shift; _tb->ok(PASS, @_) }
  2         5  
114 0     0 1 0 sub fail { shift; _tb->ok(FAIL, @_) }
  0         0  
115              
116             sub plan {
117 3     3 1 8 my $self = shift;
118              
119 3         10 return _tb->plan(@_);
120             }
121              
122             sub skip {
123 1     1 1 6 my ($self, $why, $how_many) = @_;
124              
125             # If the plan is set, and is static, then skip needs a count. If the plan
126             # is 'no_plan' we are fine. As well if plan is undefined then we are
127             # waiting for done_testing.
128 1 50       3 unless (defined $how_many) {
129 0         0 my $plan = _tb->has_plan;
130 0 0 0     0 _carp "skip() needs to know \$how_many tests are in the block"
131             if $plan && $plan =~ m/^\d+$/;
132 0         0 $how_many = 1;
133             }
134              
135 1 50 33     7 if(defined $how_many and $how_many =~ /\D/) {
136 0         0 _carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?";
137 0         0 $how_many = 1;
138             }
139              
140 1         5 for(1 .. $how_many) {
141 1         3 _tb->skip($why);
142             }
143              
144 21     21   170 no warnings 'exiting';
  21         38  
  21         83329  
145 1         471 last SKIP;
146             }
147              
148             sub BAIL_OUT {
149 0 0   0 1 0 _tb->BAIL_OUT(scalar @_ == 1 ? $_[0] : $_[1]);
150             }
151              
152             sub name {
153 18     18 1 42 my ($self, $name) = @_;
154              
155 18 50       39 if (defined $name) {
156 18         33 $self->{_name} = $name;
157             }
158              
159 18         54 $self;
160             }
161              
162             sub expected {
163 36     36 1 73 my ($self, $value) = @_;
164              
165 36         58 my $arg_count = scalar(@_) - 1;
166              
167 36 100       95 if ($arg_count > 1) {
168 1         5 _croak "'expected' method expects just only one arg. You passed $arg_count args.";
169             }
170              
171 35         51 $self->{_expected} = $value;
172              
173 35         103 $self;
174             }
175              
176             sub got {
177 44     44 1 85 my ($self, $value) = @_;
178              
179 44         69 my $arg_count = scalar(@_) - 1;
180              
181 44 100       95 if ($arg_count > 1) {
182 1         5 _croak "'got' method expects just only one arg. You passed $arg_count args.";
183             }
184              
185 43         87 $self->{_got} = $value;
186              
187 43         103 $self;
188             }
189              
190             sub _specific {
191 218     218   576 my ($self, $key, $value) = @_;
192              
193 218 100 100     620 if (defined $value && exists $self->{$key} && defined $self->{$key}) {
      66        
194 2         15 $key =~ s/^_//;
195 2         9 $self->diag("You set '$key' also in args.");
196             }
197              
198 218 100 100     729 return exists $self->{$key} && defined $self->{$key} ? $self->{$key} : $value;
199             }
200              
201             sub ok {
202 26     26 1 553 my ($self, $value, $name) = @_;
203              
204 26         62 my $got = $self->_specific('_got', $value);
205 26 100       62 my $test_name = defined $name ? $name : $self->{_name};
206              
207 26         65 _tb->ok($got, $test_name);
208              
209 26         11630 $self->_reset;
210              
211 26         180 $value;
212             }
213              
214             sub to_be {
215 3     3 1 5 my ($self, $got, $name) = @_;
216              
217 3         5 my $expected = $self->{_expected};
218 3         5 my $test_name = $self->_specific('_name', $name);
219              
220 3         5 my $ret = _tb->is_eq($got, $expected, $test_name);
221              
222 3         1363 $self->_reset;
223              
224 3         6 $ret;
225             }
226              
227             sub _test {
228 28     28   35 my $self = shift;
229 28         38 my $method = shift;
230              
231 28         69 my $got = $self->_specific('_got', $_[0]);
232 28         59 my $expected = $self->_specific('_expected', $_[1]);
233 28         57 my $test_name = $self->_specific('_name', $_[2]);
234              
235 28         47 local $Test::Builder::Level = 2;
236 28         50 my $ret = _tb->$method($got, $expected, $test_name);
237              
238 28         13507 $self->_reset;
239              
240 28         57 $ret;
241             }
242              
243 9     9 1 23 sub is { shift->_test('is_eq', @_) }
244              
245 4     4 1 9 sub isnt { shift->_test('isnt_eq', @_) }
246              
247 4     4 1 9 sub is_num { shift->_test('is_num', @_) }
248              
249 4     4 1 9 sub isnt_num { shift->_test('isnt_num', @_) }
250              
251 7     7 1 17 sub like { shift->_test('like', @_) }
252              
253             sub unlike {
254 4     4 1 14 my $self = shift;
255              
256 4         9 my $got = $self->_specific('_got', $_[0]);
257 4         8 my $expected = $self->_specific('_expected', $_[1]);
258 4         7 my $test_name = $self->_specific('_name', $_[2]);
259              
260 4         7 my $ret = _tb->unlike($got, $expected, $test_name);
261              
262 4         1893 $self->_reset;
263              
264 4 50       13 return $ret if $ret eq '1';
265              
266 0         0 my $pos = Text::MatchedPosition->new($got, $expected);
267 0         0 return _tb->diag( sprintf <<'DIAGNOSTIC', $pos->line, $pos->offset );
268             matched at line: %d, offset: %d
269             DIAGNOSTIC
270             }
271              
272             sub diag {
273 6     6 1 13708 my $self = shift;
274              
275 6         10 _tb->diag(@_);
276              
277 6         1858 $self;
278             }
279              
280             sub note {
281 1     1 1 2 my $self = shift;
282              
283 1         3 _tb->note(@_);
284              
285 1         272 $self;
286             }
287              
288             sub explain {
289 2     2 1 4 my $self = shift;
290              
291 2 100       5 if (scalar @_ == 0) {
292             my $hash = {
293             got => $self->{_got},
294             expected => $self->{_expected},
295             name => $self->{_name},
296 1         4 };
297 1         3 $self->diag(_tb->explain($hash));
298             }
299             else {
300 1         3 $self->diag(_tb->explain(@_));
301             }
302              
303 2         6 $self;
304             }
305              
306             sub x {
307 2     2 1 4 my $self = shift;
308              
309 2 100       8 return $self if $self->{no_x};
310              
311             my $hash = {
312             got => $self->{_got},
313             expected => $self->{_expected},
314             name => $self->{_name},
315 1         4 };
316              
317 1         3 $self->diag(_tb->explain(@_, $hash));
318              
319 1         6 $self;
320             }
321              
322             sub done_testing {
323 12     12 1 41 my $self = shift;
324              
325 12         36 _tb->done_testing(@_);
326              
327 12         8982 $self;
328             }
329              
330             sub done {
331 6     6 1 19 _tb->done_testing(@_);
332             }
333              
334             # Mostly copied from Test::More::can_ok
335             sub can_ok {
336 4     4 1 81 my ($self, $proto, @methods) = @_;
337              
338 4   66     16 my $class = ref $proto || $proto;
339              
340 4 50       10 unless($class) {
341 0         0 my $ok = _tb->ok(FAIL, "->can(...)");
342 0         0 _tb->diag(' can_ok() called with empty class or reference');
343 0         0 return $ok;
344             }
345              
346 4 50       9 unless(@methods) {
347 0         0 my $ok = _tb->ok(FAIL, "$class->can(...)");
348 0         0 _tb->diag(' can_ok() called with no methods');
349 0         0 return $ok;
350             }
351              
352 4         6 my @nok = ();
353 4         6 for my $method (@methods) {
354 5 50   5   27 _tb->_try(sub { $proto->can($method) }) or push @nok, $method;
  5         110  
355             }
356              
357 4 100       59 my $name = scalar @methods == 1 ? "$class->can('$methods[0]')" : "$class->can(...)";
358              
359 4         8 my $ok = _tb->ok(!@nok, $name);
360              
361 4         1413 _tb->diag(map " $class->can('$_') failed\n", @nok);
362              
363 4         49 return $ok;
364             }
365              
366             # Mostly copied from Test::More::isa_ok
367             sub isa_ok {
368 10     10 1 21 my $self = shift;
369              
370 10         17 my $got = $self->_specific('_got', $_[0]);
371 10         19 my $expected = $self->_specific('_expected', $_[1]);
372 10         19 my $test_name = $self->_specific('_name', $_[2]);
373              
374 10         16 my $whatami = 'class';
375 10 50       23 if (!defined $got) {
    100          
376 0         0 $whatami = 'undef';
377             }
378             elsif (ref $got) {
379 9         12 $whatami = 'reference';
380              
381 9         30 local($@, $!);
382 9         38 require Scalar::Util;
383 9 100       25 if(Scalar::Util::blessed($got)) {
384 6         13 $whatami = 'object';
385             }
386             }
387              
388             # We can't use UNIVERSAL::isa because we want to honor isa() overrides
389 10     10   17 my ($result, $error) = _tb->_try(sub { $got->isa($expected) });
  10         227  
390              
391 10 100       102 if ($error) {
392 3 50       17 _croak <
393             WHOA! I tried to call ->isa on your $whatami and got some weird error.
394             Here's the error.
395             $error
396             WHOA
397             }
398              
399             # Special case for isa_ok( [], "ARRAY" ) and like
400 10 100       18 if ($whatami eq 'reference') {
401 3         7 $result = UNIVERSAL::isa($got, $expected);
402             }
403              
404 10         19 my ($diag, $name) = $self->_get_isa_diag_name($whatami, $got, $expected, $test_name);
405              
406 10         13 my $ok;
407 10 50       12 if ($result) {
408 10         16 $ok = _tb->ok(PASS, $name);
409             }
410             else {
411 0         0 $ok = _tb->ok(FAIL, $name);
412 0         0 _tb->diag(" $diag\n");
413             }
414              
415 10         3043 $self->_reset;
416              
417 10         34 return $ok;
418             }
419              
420             sub _get_isa_diag_name {
421 10     10   16 my ($self, $whatami, $got, $expected, $test_name) = @_;
422              
423 10         12 my ($diag, $name);
424              
425 10 100       35 if (defined $test_name) {
    100          
    100          
    50          
    50          
426 2         5 $name = "'$test_name' isa '$expected'";
427 2 50       6 $diag = defined $got ? "'$test_name' isn't a '$expected'" : "'$test_name' isn't defined";
428             }
429             elsif ($whatami eq 'object') {
430 4         7 my $my_class = ref $got;
431 4         9 $test_name = qq[An object of class '$my_class'];
432 4         7 $name = "$test_name isa '$expected'";
433 4         9 $diag = "The object of class '$my_class' isn't a '$expected'";
434             }
435             elsif ($whatami eq 'reference') {
436 3         4 my $type = ref $got;
437 3         15 $test_name = qq[A reference of type '$type'];
438 3         5 $name = "$test_name isa '$expected'";
439 3         6 $diag = "The reference of type '$type' isn't a '$expected'";
440             }
441             elsif ($whatami eq 'undef') {
442 0         0 $test_name = 'undef';
443 0         0 $name = "$test_name isa '$expected'";
444 0         0 $diag = "$test_name isn't defined";
445             }
446             elsif($whatami eq 'class') {
447 1         2 $test_name = qq[The class (or class-like) '$got'];
448 1         3 $name = "$test_name isa '$expected'";
449 1         2 $diag = "$test_name isn't a '$expected'";
450             }
451             else {
452 0         0 _croak;
453             }
454              
455 10         22 return($diag, $name);
456             }
457              
458             sub throw_ok {
459 3     3 1 15 my $self = shift;
460              
461 3         4 eval { shift->() };
  3         6  
462              
463 3         22 _tb->ok(!!$@, $self->_specific('_name', $_[0]));
464              
465 3         1192 $self->_reset;
466              
467 3         9 $self;
468             }
469              
470             sub throw {
471 8     8 1 19 my $self = shift;
472 8         10 my $code = shift;
473              
474 8 50       24 _croak 'The `throw` method expects code ref.' unless ref $code eq 'CODE';
475              
476 8         12 eval { $code->() };
  8         13  
477              
478 8 50       52 if (my $e = $@) {
479 8 100       14 if (defined $_[0]) {
480 2   100     5 _tb->like($e, $_[0], $_[1] || 'Thrown correctly');
481 2         964 $self->_reset;
482             }
483             else {
484 6         14 $self->got($e);
485             }
486             }
487             else {
488 0         0 _tb->ok(FAIL);
489 0         0 $self->diag(q|Failed, because it's expected to throw an exeption, but not.|);
490             }
491              
492 8         46 $self;
493             }
494              
495             sub catch {
496 10     10 1 14 my $self = shift;
497 10         13 my $regex = shift;
498              
499 10         18 my $ret = _tb->like(
500             $self->_specific('_got', undef),
501             $regex,
502             $self->_specific('_name', $_[0]),
503             );
504              
505 10         6385 $self->_reset;
506              
507 10         17 $ret;
508             }
509              
510             sub warnings_ok {
511 8     8 1 49 my ($self, $code, $name) = @_;
512              
513 8         10 my $warn = 0;
514 8         9 eval {
515 8     8   33 local $SIG{__WARN__} = sub { $warn++ };
  8         620  
516 8         17 $code->();
517             };
518 8 50       26 if (my $e = $@) {
519 0         0 _tb->ok(FAIL);
520 0         0 $self->diag("An exception happened: $e");
521             }
522              
523 8         15 _tb->ok($warn > 0, $self->_specific('_name', $name));
524              
525 8         2589 $self->_reset;
526              
527 8         16 $self;
528             }
529              
530             sub warnings {
531 8     8 1 18 my ($self, $code, $regex, $name) = @_;
532              
533 8 50       23 _croak 'The `warn` method expects code ref.' unless ref $code eq 'CODE';
534              
535 8         11 my @warns;
536 8         24 eval {
537 8     8   30 local $SIG{__WARN__} = sub { push @warns, shift };
  8         95  
538 8         19 $code->();
539             };
540 8 50       19 if (my $e = $@) {
541 0         0 _tb->ok(FAIL);
542 0         0 $self->diag("An exception happened: $e");
543             }
544              
545 8 50       19 if (scalar @warns > 0) {
546 8         14 my $warn = join "\t", @warns;
547 8 100       15 if (defined $regex) {
548 2         3 _tb->like($warn, $regex, $self->_specific('_name', $name));
549 2         1005 $self->_reset;
550             }
551             else {
552 6         11 $self->got($warn);
553             }
554             }
555             else {
556 0         0 _tb->ok(FAIL);
557 0         0 $self->diag(q|Failed, because there is no warnings.|);
558             }
559              
560 8         42 $self;
561             }
562              
563             # The most code around is_depply is copied from Test::More::is_deeply
564             our (@Data_Stack, %Refs_Seen);
565              
566             my $DNE = bless [], 'Does::Not::Exist';
567              
568             sub _dne {
569 18     18   80 return ref $_[1] eq ref $DNE;
570             }
571              
572             sub is_deeply {
573 10     10 1 18 my $self = shift;
574              
575 10         27 my $got = $self->_specific('_got', $_[0]);
576 10         26 my $expected = $self->_specific('_expected', $_[1]);
577 10         28 my $test_name = $self->_specific('_name', $_[2]);
578              
579 10         22 _tb->_unoverload_str(\$expected, \$got);
580              
581 10         651 my $ok;
582              
583 10 100 66     59 if (!ref $got and !ref $expected) {
    50 25        
584             # neither is a reference
585 2         4 $ok = _tb->is_eq($got, $expected, $test_name);
586             }
587             elsif (!ref $got xor !ref $expected) {
588             # one's a reference, one isn't
589 0         0 $ok = _tb->ok(FAIL, $test_name);
590 0         0 _tb->diag( $self->_format_stack({ vals => [$got, $expected] }) );
591             }
592             else {
593             # both references
594 8         17 local @Data_Stack = ();
595 8         19 $ok = $self->_deep_check($got, $expected);
596 8 50       19 _tb->diag( $self->_format_stack(@Data_Stack) ) unless $ok;
597 8         13 _tb->ok($ok, $test_name);
598             }
599              
600 10         4274 $self->_reset;
601              
602 10         20 $self;
603             }
604              
605 9   25 9   53 sub __same_ref { !(!ref $_[0] xor !ref $_[1]) }
606 9   33 9   22 sub __not_ref { (!ref $_[0] and !ref $_[1]) }
607              
608             sub _deep_check {
609 9     9   16 my ($self, $e1, $e2) = @_;
610              
611 9         16 my $ok = FAIL;
612              
613             # Effectively turn %Refs_Seen into a stack. This avoids picking up
614             # the same referenced used twice (such as [\$a, \$a]) to be considered
615             # circular.
616 9         21 local %Refs_Seen = %Refs_Seen;
617              
618             {
619 9         13 _tb->_unoverload_str(\$e1, \$e2);
  9         16  
620              
621             # Either they're both references or both not.
622 9         657 my $same_ref = __same_ref($e1, $e2);
623 9         20 my $not_ref = __not_ref($e1, $e2);
624              
625 9 50 25     48 if (defined $e1 xor defined $e2) {
    50 33        
    50 25        
    100 66        
    50          
626 0         0 $ok = FAIL;
627             }
628             elsif (!defined $e1 and !defined $e2) {
629             # Shortcut if they're both undefined.
630 0         0 $ok = PASS;
631             }
632             elsif ($self->_dne($e1) xor $self->_dne($e2)) {
633 0         0 $ok = FAIL;
634             }
635             elsif ($same_ref and ($e1 eq $e2)) {
636 1         3 $ok = PASS;
637             }
638             elsif ($not_ref) {
639 0         0 $self->_push_data_stack('', [$e1, $e2]);
640 0         0 $ok = FAIL;
641             }
642             else {
643 8 50       18 if ($Refs_Seen{$e1}) {
644 0         0 return $Refs_Seen{$e1} eq $e2;
645             }
646             else {
647 8         25 $Refs_Seen{$e1} = "$e2";
648             }
649              
650 8         21 $ok = $self->__deep_check_type($ok, $e1, $e2);
651             }
652             }
653              
654 9         22 return $ok;
655             }
656              
657             sub __deep_check_type {
658 8     8   17 my ($self, $ok, $e1, $e2) = @_;
659              
660 8         18 my $type = $self->_type($e1);
661 8 50       18 $type = 'DIFFERENT' unless $self->_type($e2) eq $type;
662              
663 8 50       34 if ($type eq 'DIFFERENT') {
    100          
    50          
    0          
    0          
    0          
664 0         0 $self->_push_data_stack($type, [$e1, $e2]);
665 0         0 $ok = FAIL;
666             }
667             elsif ($type eq 'ARRAY') {
668 5         12 $ok = $self->_eq_array($e1, $e2);
669             }
670             elsif ($type eq 'HASH') {
671 3         9 $ok = $self->_eq_hash($e1, $e2);
672             }
673             elsif ($type eq 'REF') {
674 0         0 $self->_push_data_stack($type, [$e1, $e2]);
675 0         0 $ok = $self->_deep_check($$e1, $$e2);
676 0 0       0 pop @Data_Stack if $ok;
677             }
678             elsif ($type eq 'SCALAR') {
679 0         0 $self->_push_data_stack('REF', [$e1, $e2]);
680 0         0 $ok = $self->_deep_check($$e1, $$e2);
681 0 0       0 pop @Data_Stack if $ok;
682             }
683             elsif ($type) {
684 0         0 $self->_push_data_stack($type, [$e1, $e2]);
685 0         0 $ok = FAIL;
686             }
687             else {
688 0         0 _croak <<_WHOA_;
689             WHOA! No type in _deep_check
690             This should never happen! Please contact the author immediately!
691             _WHOA_
692             }
693              
694 8         18 return $ok;
695             }
696              
697             sub _push_data_stack {
698 1     1   5 my ($self, $type, $vals, $idx) = @_;
699              
700 1         3 my $hash = {};
701              
702 1 50       4 $hash->{type} = $type if $type;
703 1 50       4 $hash->{vals} = $vals if $vals;
704 1 50       27 $hash->{idx} = $idx if $idx;
705              
706 1         19 push @Data_Stack, $hash;
707             }
708              
709             sub _eq_array {
710 5     5   10 my ($self, $a1, $a2) = @_;
711              
712 5 50       12 if ( grep $self->_type($_) ne 'ARRAY', $a1, $a2 ) {
713 0         0 warn "eq_array passed a non-array ref";
714 0         0 return FAIL;
715             }
716              
717 5 50       14 return PASS if $a1 eq $a2;
718              
719 5         10 my $ok = PASS;
720 5 50       13 my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
721              
722 5         13 for (0 .. $max) {
723 8 50       16 my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
724 8 50       14 my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
725              
726 8 100       15 next if $self->_equal_nonrefs($e1, $e2);
727              
728 1         16 $self->_push_data_stack('ARRAY', [$e1, $e2], $_);
729 1         9 $ok = $self->_deep_check($e1, $e2);
730 1 50       3 pop @Data_Stack if $ok;
731              
732 1 50       5 last unless $ok;
733             }
734              
735 5         10 return $ok;
736             }
737              
738             sub _eq_hash {
739 3     3   6 my ($self, $a1, $a2) = @_;
740              
741 3 50       7 if ( grep $self->_type($_) ne 'HASH', $a1, $a2 ) {
742 0         0 warn "eq_hash passed a non-hash ref";
743 0         0 return FAIL;
744             }
745              
746 3 50       9 return PASS if $a1 eq $a2;
747              
748 3         6 my $ok = PASS;
749 3 50       11 my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
750              
751 3         7 for my $k ( keys %$bigger ) {
752 2 50       10 my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
753 2 50       6 my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
754              
755 2 50       5 next if $self->_equal_nonrefs($e1, $e2);
756              
757 0         0 $self->_push_data_stack('HASH', [$e1, $e2], $k);
758 0         0 $ok = $self->_deep_check($e1, $e2);
759 0 0       0 pop @Data_Stack if $ok;
760              
761 0 0       0 last unless $ok;
762             }
763              
764 3         7 return $ok;
765             }
766              
767             sub _equal_nonrefs {
768 10     10   17 my ($self, $e1, $e2) = @_;
769              
770 10 100 66     32 return if ref $e1 or ref $e2;
771              
772 9 50       17 if (defined $e1) {
773 9 50 33     32 return PASS if defined $e2 and $e1 eq $e2;
774             }
775             else {
776 0 0       0 return PASS if !defined $e2;
777             }
778              
779 0         0 return;
780             }
781              
782             sub _type {
783 32     32   50 my ($self, $thing) = @_;
784              
785 32 50       57 return '' if !ref $thing;
786              
787 32         43 for my $type (qw/Regexp ARRAY HASH REF SCALAR GLOB CODE VSTRING/) {
788 76 100       188 return $type if UNIVERSAL::isa($thing, $type);
789             }
790              
791 0           return '';
792             }
793              
794             sub _format_stack {
795 0     0     my ($self, @stack) = @_;
796              
797 0           my $var = '$FOO';
798 0           my $did_arrow = 0;
799              
800 0           for my $entry (@stack) {
801 0   0       my $type = $entry->{type} || '';
802 0           my $idx = $entry->{'idx'};
803 0 0         if($type eq 'HASH') {
    0          
    0          
804 0 0         $var .= "->" unless $did_arrow++;
805 0           $var .= "{$idx}";
806             }
807             elsif($type eq 'ARRAY') {
808 0 0         $var .= "->" unless $did_arrow++;
809 0           $var .= "[$idx]";
810             }
811             elsif($type eq 'REF') {
812 0           $var = "\${$var}";
813             }
814             }
815              
816 0           my @vals = @{ $stack[-1]{vals} }[ 0, 1 ];
  0            
817 0           my @vars = ();
818              
819 0           ( $vars[0] = $var ) =~ s/\$FOO/ \$got/;
820 0           ( $vars[1] = $var ) =~ s/\$FOO/\$expected/;
821              
822 0           my $out = "Structures begin differing at:\n";
823              
824 0           for my $idx (0 .. $#vals) {
825 0           my $val = $vals[$idx];
826 0 0         $vals[$idx]
    0          
    0          
827             = !defined $val ? 'undef'
828             : $self->_dne($val) ? "Does not exist"
829             : ref $val ? "$val"
830             : "'$val'";
831             }
832              
833 0           $out .= "$vars[0] = $vals[0]\n" . "$vars[1] = $vals[1]\n";
834              
835 0           $out =~ s/^/ /msg;
836              
837 0           return $out;
838             }
839              
840             {
841 21     21   174 no warnings 'once';
  21         43  
  21         1741  
842             *expect = *expected;
843              
844             *warn_ok = *warnings_ok;
845             *warning_ok = *warnings_ok;
846              
847             *warning = *warnings;
848             }
849              
850             1;
851              
852             __END__