| 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; | ||||||