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