File: | inc/Test/More.pm |
Coverage: | 39.5% |
line | stmt | bran | cond | sub | pod | time | code |
---|---|---|---|---|---|---|---|
1 | #line 1 | ||||||
2 | package Test::More; | ||||||
3 | |||||||
4 | 8 8 8 | 39 15 38 | use 5.006; | ||||
5 | use strict; | ||||||
6 | |||||||
7 | |||||||
8 | # Can't use Carp because it might cause use_ok() to accidentally succeed | ||||||
9 | # even though the module being used forgot to use Carp. Yes, this | ||||||
10 | # actually happened. | ||||||
11 | 0 | 0 | sub _carp { | ||||
12 | 0 | 0 | my($file, $line) = (caller(1))[1,2]; | ||||
13 | warn @_, " at $file line $line\n"; | ||||||
14 | } | ||||||
15 | |||||||
16 | |||||||
17 | |||||||
18 | use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); | ||||||
19 | $VERSION = '0.80'; | ||||||
20 | $VERSION = eval $VERSION; # make the alpha version come out as a number | ||||||
21 | |||||||
22 | use Test::Builder::Module; | ||||||
23 | @ISA = qw(Test::Builder::Module); | ||||||
24 | @EXPORT = qw(ok use_ok require_ok | ||||||
25 | is isnt like unlike is_deeply | ||||||
26 | cmp_ok | ||||||
27 | skip todo todo_skip | ||||||
28 | pass fail | ||||||
29 | eq_array eq_hash eq_set | ||||||
30 | $TODO | ||||||
31 | plan | ||||||
32 | can_ok isa_ok | ||||||
33 | diag | ||||||
34 | BAIL_OUT | ||||||
35 | ); | ||||||
36 | |||||||
37 | |||||||
38 | #line 156 | ||||||
39 | |||||||
40 | sub plan { | ||||||
41 | my $tb = Test::More->builder; | ||||||
42 | |||||||
43 | $tb->plan(@_); | ||||||
44 | } | ||||||
45 | |||||||
46 | |||||||
47 | # This implements "use Test::More 'no_diag'" but the behavior is | ||||||
48 | # deprecated. | ||||||
49 | sub import_extra { | ||||||
50 | my $class = shift; | ||||||
51 | my $list = shift; | ||||||
52 | |||||||
53 | my @other = (); | ||||||
54 | my $idx = 0; | ||||||
55 | while( $idx <= $#{$list} ) { | ||||||
56 | my $item = $list->[$idx]; | ||||||
57 | |||||||
58 | if( defined $item and $item eq 'no_diag' ) { | ||||||
59 | $class->builder->no_diag(1); | ||||||
60 | } | ||||||
61 | else { | ||||||
62 | push @other, $item; | ||||||
63 | } | ||||||
64 | |||||||
65 | $idx++; | ||||||
66 | } | ||||||
67 | |||||||
68 | @$list = @other; | ||||||
69 | } | ||||||
70 | |||||||
71 | |||||||
72 | #line 256 | ||||||
73 | |||||||
74 | sub ok ($;$) { | ||||||
75 | my($test, $name) = @_; | ||||||
76 | my $tb = Test::More->builder; | ||||||
77 | |||||||
78 | $tb->ok($test, $name); | ||||||
79 | } | ||||||
80 | |||||||
81 | #line 323 | ||||||
82 | |||||||
83 | sub is ($$;$) { | ||||||
84 | my $tb = Test::More->builder; | ||||||
85 | |||||||
86 | $tb->is_eq(@_); | ||||||
87 | } | ||||||
88 | |||||||
89 | sub isnt ($$;$) { | ||||||
90 | my $tb = Test::More->builder; | ||||||
91 | |||||||
92 | $tb->isnt_eq(@_); | ||||||
93 | } | ||||||
94 | |||||||
95 | *isn't = \&isnt; | ||||||
96 | |||||||
97 | |||||||
98 | #line 368 | ||||||
99 | |||||||
100 | sub like ($$;$) { | ||||||
101 | my $tb = Test::More->builder; | ||||||
102 | |||||||
103 | $tb->like(@_); | ||||||
104 | } | ||||||
105 | |||||||
106 | |||||||
107 | #line 384 | ||||||
108 | |||||||
109 | sub unlike ($$;$) { | ||||||
110 | my $tb = Test::More->builder; | ||||||
111 | |||||||
112 | $tb->unlike(@_); | ||||||
113 | } | ||||||
114 | |||||||
115 | |||||||
116 | #line 424 | ||||||
117 | |||||||
118 | sub cmp_ok($$$;$) { | ||||||
119 | my $tb = Test::More->builder; | ||||||
120 | |||||||
121 | $tb->cmp_ok(@_); | ||||||
122 | } | ||||||
123 | |||||||
124 | |||||||
125 | #line 460 | ||||||
126 | |||||||
127 | sub can_ok ($@) { | ||||||
128 | my($proto, @methods) = @_; | ||||||
129 | my $class = ref $proto || $proto; | ||||||
130 | my $tb = Test::More->builder; | ||||||
131 | |||||||
132 | unless( $class ) { | ||||||
133 | my $ok = $tb->ok( 0, "->can(...)" ); | ||||||
134 | $tb->diag(' can_ok() called with empty class or reference'); | ||||||
135 | return $ok; | ||||||
136 | } | ||||||
137 | |||||||
138 | unless( @methods ) { | ||||||
139 | my $ok = $tb->ok( 0, "$class->can(...)" ); | ||||||
140 | $tb->diag(' can_ok() called with no methods'); | ||||||
141 | return $ok; | ||||||
142 | } | ||||||
143 | |||||||
144 | my @nok = (); | ||||||
145 | foreach my $method (@methods) { | ||||||
146 | $tb->_try(sub { $proto->can($method) }) or push @nok, $method; | ||||||
147 | } | ||||||
148 | |||||||
149 | my $name; | ||||||
150 | $name = @methods == 1 ? "$class->can('$methods[0]')" | ||||||
151 | : "$class->can(...)"; | ||||||
152 | |||||||
153 | my $ok = $tb->ok( !@nok, $name ); | ||||||
154 | |||||||
155 | $tb->diag(map " $class->can('$_') failed\n", @nok); | ||||||
156 | |||||||
157 | return $ok; | ||||||
158 | 0 | 1 | 0 | } | |||
159 | |||||||
160 | 0 | 0 | #line 522 | ||||
161 | |||||||
162 | sub isa_ok ($$;$) { | ||||||
163 | my($object, $class, $obj_name) = @_; | ||||||
164 | my $tb = Test::More->builder; | ||||||
165 | |||||||
166 | my $diag; | ||||||
167 | 8 | 1 | 92 | $obj_name = 'The object' unless defined $obj_name; | |||
168 | 8 | 17 | my $name = "$obj_name isa $class"; | ||||
169 | if( !defined $object ) { | ||||||
170 | 8 | 20 | $diag = "$obj_name isn't defined"; | ||||
171 | 8 | 18 | } | ||||
172 | 8 14 | 14 79 | elsif( !ref $object ) { | ||||
173 | 6 | 16 | $diag = "$obj_name isn't a reference"; | ||||
174 | } | ||||||
175 | 6 | 46 | else { | ||||
176 | 0 | 0 | # We can't use UNIVERSAL::isa because we want to honor isa() overrides | ||||
177 | my($rslt, $error) = $tb->_try(sub { $object->isa($class) }); | ||||||
178 | if( $error ) { | ||||||
179 | 6 | 21 | if( $error =~ /^Can't call method "isa" on unblessed reference/ ) { | ||||
180 | # Its an unblessed reference | ||||||
181 | if( !UNIVERSAL::isa($object, $class) ) { | ||||||
182 | 6 | 13 | my $ref = ref $object; | ||||
183 | $diag = "$obj_name isn't a '$class' it's a '$ref'"; | ||||||
184 | } | ||||||
185 | 8 | 38 | } else { | ||||
186 | die <<WHOA; | ||||||
187 | WHOA! I tried to call ->isa on your object and got some weird error. | ||||||
188 | Here's the error. | ||||||
189 | $error | ||||||
190 | WHOA | ||||||
191 | } | ||||||
192 | } | ||||||
193 | elsif( !$rslt ) { | ||||||
194 | my $ref = ref $object; | ||||||
195 | $diag = "$obj_name isn't a '$class' it's a '$ref'"; | ||||||
196 | } | ||||||
197 | } | ||||||
198 | |||||||
199 | |||||||
200 | |||||||
201 | my $ok; | ||||||
202 | if( $diag ) { | ||||||
203 | $ok = $tb->ok( 0, $name ); | ||||||
204 | $tb->diag(" $diag\n"); | ||||||
205 | } | ||||||
206 | else { | ||||||
207 | $ok = $tb->ok( 1, $name ); | ||||||
208 | } | ||||||
209 | |||||||
210 | return $ok; | ||||||
211 | } | ||||||
212 | |||||||
213 | |||||||
214 | #line 591 | ||||||
215 | |||||||
216 | sub pass (;$) { | ||||||
217 | my $tb = Test::More->builder; | ||||||
218 | $tb->ok(1, @_); | ||||||
219 | } | ||||||
220 | |||||||
221 | sub fail (;$) { | ||||||
222 | my $tb = Test::More->builder; | ||||||
223 | $tb->ok(0, @_); | ||||||
224 | } | ||||||
225 | |||||||
226 | #line 652 | ||||||
227 | |||||||
228 | sub use_ok ($;@) { | ||||||
229 | my($module, @imports) = @_; | ||||||
230 | @imports = () unless @imports; | ||||||
231 | my $tb = Test::More->builder; | ||||||
232 | |||||||
233 | my($pack,$filename,$line) = caller; | ||||||
234 | |||||||
235 | my $code; | ||||||
236 | if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { | ||||||
237 | # probably a version check. Perl needs to see the bare number | ||||||
238 | # for it to work with non-Exporter based modules. | ||||||
239 | $code = <<USE; | ||||||
240 | package $pack; | ||||||
241 | use $module $imports[0]; | ||||||
242 | 1; | ||||||
243 | USE | ||||||
244 | } | ||||||
245 | else { | ||||||
246 | $code = <<USE; | ||||||
247 | package $pack; | ||||||
248 | use $module \@{\$args[0]}; | ||||||
249 | 1; | ||||||
250 | USE | ||||||
251 | } | ||||||
252 | |||||||
253 | |||||||
254 | my($eval_result, $eval_error) = _eval($code, \@imports); | ||||||
255 | my $ok = $tb->ok( $eval_result, "use $module;" ); | ||||||
256 | |||||||
257 | unless( $ok ) { | ||||||
258 | 3 | 1 | 42 | chomp $eval_error; | |||
259 | 3 | 15 | $@ =~ s{^BEGIN failed--compilation aborted at .*$} | ||||
260 | {BEGIN failed--compilation aborted at $filename line $line.}m; | ||||||
261 | 3 | 11 | $tb->diag(<<DIAGNOSTIC); | ||||
262 | Tried to use '$module'. | ||||||
263 | Error: $eval_error | ||||||
264 | DIAGNOSTIC | ||||||
265 | |||||||
266 | } | ||||||
267 | |||||||
268 | return $ok; | ||||||
269 | } | ||||||
270 | |||||||
271 | |||||||
272 | sub _eval { | ||||||
273 | my($code) = shift; | ||||||
274 | my @args = @_; | ||||||
275 | |||||||
276 | # Work around oddities surrounding resetting of $@ by immediately | ||||||
277 | # storing it. | ||||||
278 | local($@,$!,$SIG{__DIE__}); # isolate eval | ||||||
279 | my $eval_result = eval $code; | ||||||
280 | my $eval_error = $@; | ||||||
281 | |||||||
282 | return($eval_result, $eval_error); | ||||||
283 | } | ||||||
284 | |||||||
285 | #line 718 | ||||||
286 | |||||||
287 | sub require_ok ($) { | ||||||
288 | my($module) = shift; | ||||||
289 | my $tb = Test::More->builder; | ||||||
290 | |||||||
291 | my $pack = caller; | ||||||
292 | |||||||
293 | # Try to deterine if we've been given a module name or file. | ||||||
294 | # Module names must be barewords, files not. | ||||||
295 | $module = qq['$module'] unless _is_module_name($module); | ||||||
296 | |||||||
297 | my $code = <<REQUIRE; | ||||||
298 | package $pack; | ||||||
299 | require $module; | ||||||
300 | 1; | ||||||
301 | REQUIRE | ||||||
302 | |||||||
303 | my($eval_result, $eval_error) = _eval($code); | ||||||
304 | my $ok = $tb->ok( $eval_result, "require $module;" ); | ||||||
305 | |||||||
306 | unless( $ok ) { | ||||||
307 | chomp $eval_error; | ||||||
308 | $tb->diag(<<DIAGNOSTIC); | ||||||
309 | Tried to require '$module'. | ||||||
310 | Error: $eval_error | ||||||
311 | DIAGNOSTIC | ||||||
312 | |||||||
313 | } | ||||||
314 | |||||||
315 | return $ok; | ||||||
316 | } | ||||||
317 | |||||||
318 | |||||||
319 | sub _is_module_name { | ||||||
320 | my $module = shift; | ||||||
321 | |||||||
322 | # Module names start with a letter. | ||||||
323 | # End with an alphanumeric. | ||||||
324 | # The rest is an alphanumeric or :: | ||||||
325 | 129 | 1 | 1135 | $module =~ s/\b::\b//g; | |||
326 | $module =~ /^[a-zA-Z]\w*$/; | ||||||
327 | 129 | 413 | } | ||||
328 | |||||||
329 | #line 795 | ||||||
330 | |||||||
331 | 1 | 1 | 7 | use vars qw(@Data_Stack %Refs_Seen); | |||
332 | my $DNE = bless [], 'Does::Not::Exist'; | ||||||
333 | |||||||
334 | sub _dne { | ||||||
335 | ref $_[0] eq ref $DNE; | ||||||
336 | } | ||||||
337 | |||||||
338 | |||||||
339 | sub is_deeply { | ||||||
340 | my $tb = Test::More->builder; | ||||||
341 | |||||||
342 | unless( @_ == 2 or @_ == 3 ) { | ||||||
343 | my $msg = <<WARNING; | ||||||
344 | is_deeply() takes two or three args, you gave %d. | ||||||
345 | This usually means you passed an array or hash instead | ||||||
346 | of a reference to it | ||||||
347 | WARNING | ||||||
348 | chop $msg; # clip off newline so carp() will put in line/file | ||||||
349 | |||||||
350 | _carp sprintf $msg, scalar @_; | ||||||
351 | |||||||
352 | return $tb->ok(0); | ||||||
353 | } | ||||||
354 | |||||||
355 | my($got, $expected, $name) = @_; | ||||||
356 | |||||||
357 | $tb->_unoverload_str(\$expected, \$got); | ||||||
358 | |||||||
359 | my $ok; | ||||||
360 | if( !ref $got and !ref $expected ) { # neither is a reference | ||||||
361 | $ok = $tb->is_eq($got, $expected, $name); | ||||||
362 | } | ||||||
363 | elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't | ||||||
364 | $ok = $tb->ok(0, $name); | ||||||
365 | $tb->diag( _format_stack({ vals => [ $got, $expected ] }) ); | ||||||
366 | } | ||||||
367 | else { # both references | ||||||
368 | local @Data_Stack = (); | ||||||
369 | if( _deep_check($got, $expected) ) { | ||||||
370 | 0 | 1 | 0 | $ok = $tb->ok(1, $name); | |||
371 | } | ||||||
372 | 0 | 0 | else { | ||||
373 | $ok = $tb->ok(0, $name); | ||||||
374 | $tb->diag(_format_stack(@Data_Stack)); | ||||||
375 | } | ||||||
376 | } | ||||||
377 | |||||||
378 | return $ok; | ||||||
379 | } | ||||||
380 | |||||||
381 | sub _format_stack { | ||||||
382 | my(@Stack) = @_; | ||||||
383 | |||||||
384 | my $var = '$FOO'; | ||||||
385 | my $did_arrow = 0; | ||||||
386 | 0 | 1 | 0 | foreach my $entry (@Stack) { | |||
387 | my $type = $entry->{type} || ''; | ||||||
388 | 0 | 0 | my $idx = $entry->{'idx'}; | ||||
389 | if( $type eq 'HASH' ) { | ||||||
390 | $var .= "->" unless $did_arrow++; | ||||||
391 | $var .= "{$idx}"; | ||||||
392 | } | ||||||
393 | elsif( $type eq 'ARRAY' ) { | ||||||
394 | $var .= "->" unless $did_arrow++; | ||||||
395 | $var .= "[$idx]"; | ||||||
396 | } | ||||||
397 | elsif( $type eq 'REF' ) { | ||||||
398 | $var = "\${$var}"; | ||||||
399 | } | ||||||
400 | } | ||||||
401 | |||||||
402 | my @vals = @{$Stack[-1]{vals}}[0,1]; | ||||||
403 | my @vars = (); | ||||||
404 | ($vars[0] = $var) =~ s/\$FOO/ \$got/; | ||||||
405 | ($vars[1] = $var) =~ s/\$FOO/\$expected/; | ||||||
406 | |||||||
407 | my $out = "Structures begin differing at:\n"; | ||||||
408 | foreach my $idx (0..$#vals) { | ||||||
409 | my $val = $vals[$idx]; | ||||||
410 | $vals[$idx] = !defined $val ? 'undef' : | ||||||
411 | _dne($val) ? "Does not exist" : | ||||||
412 | ref $val ? "$val" : | ||||||
413 | "'$val'"; | ||||||
414 | } | ||||||
415 | |||||||
416 | $out .= "$vars[0] = $vals[0]\n"; | ||||||
417 | $out .= "$vars[1] = $vals[1]\n"; | ||||||
418 | |||||||
419 | $out =~ s/^/ /msg; | ||||||
420 | return $out; | ||||||
421 | } | ||||||
422 | |||||||
423 | |||||||
424 | sub _type { | ||||||
425 | my $thing = shift; | ||||||
426 | |||||||
427 | return '' if !ref $thing; | ||||||
428 | |||||||
429 | for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) { | ||||||
430 | return $type if UNIVERSAL::isa($thing, $type); | ||||||
431 | } | ||||||
432 | |||||||
433 | return ''; | ||||||
434 | } | ||||||
435 | |||||||
436 | #line 941 | ||||||
437 | |||||||
438 | sub diag { | ||||||
439 | my $tb = Test::More->builder; | ||||||
440 | |||||||
441 | $tb->diag(@_); | ||||||
442 | } | ||||||
443 | |||||||
444 | |||||||
445 | #line 1010 | ||||||
446 | |||||||
447 | #'# | ||||||
448 | sub skip { | ||||||
449 | my($why, $how_many) = @_; | ||||||
450 | my $tb = Test::More->builder; | ||||||
451 | |||||||
452 | unless( defined $how_many ) { | ||||||
453 | # $how_many can only be avoided when no_plan is in use. | ||||||
454 | _carp "skip() needs to know \$how_many tests are in the block" | ||||||
455 | unless $tb->has_plan eq 'no_plan'; | ||||||
456 | $how_many = 1; | ||||||
457 | } | ||||||
458 | |||||||
459 | if( defined $how_many and $how_many =~ /\D/ ) { | ||||||
460 | _carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; | ||||||
461 | $how_many = 1; | ||||||
462 | 0 | 1 | 0 | } | |||
463 | |||||||
464 | 0 | 0 | for( 1..$how_many ) { | ||||
465 | $tb->skip($why); | ||||||
466 | 0 | 0 | } | ||||
467 | |||||||
468 | 0 | 0 | local $^W = 0; | ||||
469 | 0 | 0 | last SKIP; | ||||
470 | } | ||||||
471 | |||||||
472 | |||||||
473 | 0 | 0 | #line 1097 | ||||
474 | |||||||
475 | 0 | 0 | sub todo_skip { | ||||
476 | my($why, $how_many) = @_; | ||||||
477 | my $tb = Test::More->builder; | ||||||
478 | |||||||
479 | 0 | 0 | unless( defined $how_many ) { | ||||
480 | 0 0 | 0 0 | # $how_many can only be avoided when no_plan is in use. | ||||
481 | _carp "todo_skip() needs to know \$how_many tests are in the block" | ||||||
482 | unless $tb->has_plan eq 'no_plan'; | ||||||
483 | 0 | 0 | $how_many = 1; | ||||
484 | 0 | 0 | } | ||||
485 | |||||||
486 | for( 1..$how_many ) { | ||||||
487 | 0 | 0 | $tb->todo_skip($why); | ||||
488 | } | ||||||
489 | |||||||
490 | local $^W = 0; | ||||||
491 | 0 | 0 | last TODO; | ||||
492 | } | ||||||
493 | |||||||
494 | #line 1150 | ||||||
495 | |||||||
496 | sub BAIL_OUT { | ||||||
497 | my $reason = shift; | ||||||
498 | my $tb = Test::More->builder; | ||||||
499 | |||||||
500 | $tb->BAIL_OUT($reason); | ||||||
501 | } | ||||||
502 | |||||||
503 | #line 1189 | ||||||
504 | |||||||
505 | #'# | ||||||
506 | sub eq_array { | ||||||
507 | local @Data_Stack; | ||||||
508 | _deep_check(@_); | ||||||
509 | } | ||||||
510 | |||||||
511 | sub _eq_array { | ||||||
512 | my($a1, $a2) = @_; | ||||||
513 | |||||||
514 | if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) { | ||||||
515 | warn "eq_array passed a non-array ref"; | ||||||
516 | return 0; | ||||||
517 | } | ||||||
518 | |||||||
519 | return 1 if $a1 eq $a2; | ||||||
520 | |||||||
521 | my $ok = 1; | ||||||
522 | my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; | ||||||
523 | for (0..$max) { | ||||||
524 | 0 | 1 | 0 | my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; | |||
525 | 0 | 0 | my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; | ||||
526 | |||||||
527 | 0 | 0 | push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; | ||||
528 | 0 | 0 | $ok = _deep_check($e1,$e2); | ||||
529 | 0 | 0 | pop @Data_Stack if $ok; | ||||
530 | |||||||
531 | 0 | 0 | last unless $ok; | ||||
532 | } | ||||||
533 | |||||||
534 | 0 | 0 | return $ok; | ||||
535 | } | ||||||
536 | |||||||
537 | sub _deep_check { | ||||||
538 | 0 0 | 0 0 | my($e1, $e2) = @_; | ||||
539 | 0 | 0 | my $tb = Test::More->builder; | ||||
540 | |||||||
541 | my $ok = 0; | ||||||
542 | |||||||
543 | 0 | 0 | # Effectively turn %Refs_Seen into a stack. This avoids picking up | ||||
544 | 0 | 0 | # the same referenced used twice (such as [\$a, \$a]) to be considered | ||||
545 | # circular. | ||||||
546 | local %Refs_Seen = %Refs_Seen; | ||||||
547 | |||||||
548 | { | ||||||
549 | # Quiet uninitialized value warnings when comparing undefs. | ||||||
550 | local $^W = 0; | ||||||
551 | |||||||
552 | $tb->_unoverload_str(\$e1, \$e2); | ||||||
553 | |||||||
554 | # Either they're both references or both not. | ||||||
555 | 0 | 0 | my $same_ref = !(!ref $e1 xor !ref $e2); | ||||
556 | 0 | 0 | my $not_ref = (!ref $e1 and !ref $e2); | ||||
557 | |||||||
558 | if( defined $e1 xor defined $e2 ) { | ||||||
559 | $ok = 0; | ||||||
560 | } | ||||||
561 | elsif ( _dne($e1) xor _dne($e2) ) { | ||||||
562 | 0 | 0 | $ok = 0; | ||||
563 | 0 | 0 | } | ||||
564 | 0 | 0 | elsif ( $same_ref and ($e1 eq $e2) ) { | ||||
565 | 0 | 0 | $ok = 1; | ||||
566 | } | ||||||
567 | elsif ( $not_ref ) { | ||||||
568 | 0 | 0 | push @Data_Stack, { type => '', vals => [$e1, $e2] }; | ||||
569 | $ok = 0; | ||||||
570 | } | ||||||
571 | 0 | 0 | else { | ||||
572 | if( $Refs_Seen{$e1} ) { | ||||||
573 | return $Refs_Seen{$e1} eq $e2; | ||||||
574 | } | ||||||
575 | else { | ||||||
576 | $Refs_Seen{$e1} = "$e2"; | ||||||
577 | } | ||||||
578 | |||||||
579 | my $type = _type($e1); | ||||||
580 | $type = 'DIFFERENT' unless _type($e2) eq $type; | ||||||
581 | |||||||
582 | if( $type eq 'DIFFERENT' ) { | ||||||
583 | push @Data_Stack, { type => $type, vals => [$e1, $e2] }; | ||||||
584 | $ok = 0; | ||||||
585 | } | ||||||
586 | elsif( $type eq 'ARRAY' ) { | ||||||
587 | $ok = _eq_array($e1, $e2); | ||||||
588 | } | ||||||
589 | elsif( $type eq 'HASH' ) { | ||||||
590 | $ok = _eq_hash($e1, $e2); | ||||||
591 | } | ||||||
592 | elsif( $type eq 'REF' ) { | ||||||
593 | 0 | 1 | 0 | push @Data_Stack, { type => $type, vals => [$e1, $e2] }; | |||
594 | 0 | 0 | $ok = _deep_check($$e1, $$e2); | ||||
595 | pop @Data_Stack if $ok; | ||||||
596 | } | ||||||
597 | elsif( $type eq 'SCALAR' ) { | ||||||
598 | 0 | 1 | 0 | push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; | |||
599 | 0 | 0 | $ok = _deep_check($$e1, $$e2); | ||||
600 | pop @Data_Stack if $ok; | ||||||
601 | } | ||||||
602 | elsif( $type ) { | ||||||
603 | push @Data_Stack, { type => $type, vals => [$e1, $e2] }; | ||||||
604 | $ok = 0; | ||||||
605 | } | ||||||
606 | else { | ||||||
607 | _whoa(1, "No type in _deep_check"); | ||||||
608 | } | ||||||
609 | } | ||||||
610 | } | ||||||
611 | |||||||
612 | return $ok; | ||||||
613 | } | ||||||
614 | |||||||
615 | |||||||
616 | sub _whoa { | ||||||
617 | my($check, $desc) = @_; | ||||||
618 | if( $check ) { | ||||||
619 | die <<WHOA; | ||||||
620 | WHOA! $desc | ||||||
621 | This should never happen! Please contact the author immediately! | ||||||
622 | WHOA | ||||||
623 | } | ||||||
624 | } | ||||||
625 | |||||||
626 | |||||||
627 | #line 1320 | ||||||
628 | |||||||
629 | sub eq_hash { | ||||||
630 | local @Data_Stack; | ||||||
631 | return _deep_check(@_); | ||||||
632 | } | ||||||
633 | |||||||
634 | sub _eq_hash { | ||||||
635 | my($a1, $a2) = @_; | ||||||
636 | |||||||
637 | if( grep !_type($_) eq 'HASH', $a1, $a2 ) { | ||||||
638 | warn "eq_hash passed a non-hash ref"; | ||||||
639 | return 0; | ||||||
640 | } | ||||||
641 | |||||||
642 | return 1 if $a1 eq $a2; | ||||||
643 | |||||||
644 | my $ok = 1; | ||||||
645 | my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; | ||||||
646 | foreach my $k (keys %$bigger) { | ||||||
647 | my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; | ||||||
648 | my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; | ||||||
649 | |||||||
650 | push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; | ||||||
651 | $ok = _deep_check($e1, $e2); | ||||||
652 | pop @Data_Stack if $ok; | ||||||
653 | |||||||
654 | 1 | 1 | 4 | last unless $ok; | |||
655 | 1 | 4 | } | ||||
656 | |||||||
657 | return $ok; | ||||||
658 | 1 | 5 | } | ||||
659 | |||||||
660 | 1 | 3 | #line 1377 | ||||
661 | |||||||
662 | sub eq_set { | ||||||
663 | my($a1, $a2) = @_; | ||||||
664 | 0 | 0 | return 0 unless @$a1 == @$a2; | ||||
665 | |||||||
666 | # There's faster ways to do this, but this is easiest. | ||||||
667 | local $^W = 0; | ||||||
668 | |||||||
669 | # It really doesn't matter how we sort them, as long as both arrays are | ||||||
670 | # sorted with the same algorithm. | ||||||
671 | 1 | 6 | # | ||||
672 | # Ensure that references are not accidentally treated the same as a | ||||||
673 | # string containing the reference. | ||||||
674 | # | ||||||
675 | # Have to inline the sort routine due to a threading/sort bug. | ||||||
676 | # See [rt.cpan.org 6782] | ||||||
677 | # | ||||||
678 | # I don't know how references would be sorted so we just don't sort | ||||||
679 | 1 | 5 | # them. This means eq_set doesn't really work with refs. | ||||
680 | 1 | 10 | return eq_array( | ||||
681 | [grep(ref, @$a1), sort( grep(!ref, @$a1) )], | ||||||
682 | 1 | 4 | [grep(ref, @$a2), sort( grep(!ref, @$a2) )], | ||||
683 | 0 | 0 | ); | ||||
684 | 0 | 0 | } | ||||
685 | |||||||
686 | 0 | 0 | #line 1567 | ||||
687 | |||||||
688 | 1; |