1#line 1 2package Test::More; 3 4use 5.006; 5use 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. 11sub _carp { 12 my($file, $line) = (caller(1))[1,2]; 13 warn @_, " at $file line $line\n"; 14} 15 16 17 18use 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 22use 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 40sub 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. 49sub 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 74sub ok ($;$) { 75 my($test, $name) = @_; 76 my $tb = Test::More->builder; 77 78 $tb->ok($test, $name); 79} 80 81#line 323 82 83sub is ($$;$) { 84 my $tb = Test::More->builder; 85 86 $tb->is_eq(@_); 87} 88 89sub isnt ($$;$) { 90 my $tb = Test::More->builder; 91 92 $tb->isnt_eq(@_); 93} 94 95*isn't = \&isnt; 96 97 98#line 368 99 100sub like ($$;$) { 101 my $tb = Test::More->builder; 102 103 $tb->like(@_); 104} 105 106 107#line 384 108 109sub unlike ($$;$) { 110 my $tb = Test::More->builder; 111 112 $tb->unlike(@_); 113} 114 115 116#line 424 117 118sub cmp_ok($$$;$) { 119 my $tb = Test::More->builder; 120 121 $tb->cmp_ok(@_); 122} 123 124 125#line 460 126 127sub 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} 159 160#line 522 161 162sub isa_ok ($$;$) { 163 my($object, $class, $obj_name) = @_; 164 my $tb = Test::More->builder; 165 166 my $diag; 167 $obj_name = 'The object' unless defined $obj_name; 168 my $name = "$obj_name isa $class"; 169 if( !defined $object ) { 170 $diag = "$obj_name isn't defined"; 171 } 172 elsif( !ref $object ) { 173 $diag = "$obj_name isn't a reference"; 174 } 175 else { 176 # 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 if( $error =~ /^Can't call method "isa" on unblessed reference/ ) { 180 # Its an unblessed reference 181 if( !UNIVERSAL::isa($object, $class) ) { 182 my $ref = ref $object; 183 $diag = "$obj_name isn't a '$class' it's a '$ref'"; 184 } 185 } else { 186 die <<WHOA; 187WHOA! I tried to call ->isa on your object and got some weird error. 188Here's the error. 189$error 190WHOA 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 216sub pass (;$) { 217 my $tb = Test::More->builder; 218 $tb->ok(1, @_); 219} 220 221sub fail (;$) { 222 my $tb = Test::More->builder; 223 $tb->ok(0, @_); 224} 225 226#line 652 227 228sub 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; 240package $pack; 241use $module $imports[0]; 2421; 243USE 244 } 245 else { 246 $code = <<USE; 247package $pack; 248use $module \@{\$args[0]}; 2491; 250USE 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 chomp $eval_error; 259 $@ =~ s{^BEGIN failed--compilation aborted at .*$} 260 {BEGIN failed--compilation aborted at $filename line $line.}m; 261 $tb->diag(<<DIAGNOSTIC); 262 Tried to use '$module'. 263 Error: $eval_error 264DIAGNOSTIC 265 266 } 267 268 return $ok; 269} 270 271 272sub _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 287sub 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; 298package $pack; 299require $module; 3001; 301REQUIRE 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 311DIAGNOSTIC 312 313 } 314 315 return $ok; 316} 317 318 319sub _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 $module =~ s/\b::\b//g; 326 $module =~ /^[a-zA-Z]\w*$/; 327} 328 329#line 795 330 331use vars qw(@Data_Stack %Refs_Seen); 332my $DNE = bless [], 'Does::Not::Exist'; 333 334sub _dne { 335 ref $_[0] eq ref $DNE; 336} 337 338 339sub is_deeply { 340 my $tb = Test::More->builder; 341 342 unless( @_ == 2 or @_ == 3 ) { 343 my $msg = <<WARNING; 344is_deeply() takes two or three args, you gave %d. 345This usually means you passed an array or hash instead 346of a reference to it 347WARNING 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 $ok = $tb->ok(1, $name); 371 } 372 else { 373 $ok = $tb->ok(0, $name); 374 $tb->diag(_format_stack(@Data_Stack)); 375 } 376 } 377 378 return $ok; 379} 380 381sub _format_stack { 382 my(@Stack) = @_; 383 384 my $var = '$FOO'; 385 my $did_arrow = 0; 386 foreach my $entry (@Stack) { 387 my $type = $entry->{type} || ''; 388 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 424sub _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 438sub diag { 439 my $tb = Test::More->builder; 440 441 $tb->diag(@_); 442} 443 444 445#line 1010 446 447#'# 448sub 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 } 463 464 for( 1..$how_many ) { 465 $tb->skip($why); 466 } 467 468 local $^W = 0; 469 last SKIP; 470} 471 472 473#line 1097 474 475sub todo_skip { 476 my($why, $how_many) = @_; 477 my $tb = Test::More->builder; 478 479 unless( defined $how_many ) { 480 # $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 $how_many = 1; 484 } 485 486 for( 1..$how_many ) { 487 $tb->todo_skip($why); 488 } 489 490 local $^W = 0; 491 last TODO; 492} 493 494#line 1150 495 496sub 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#'# 506sub eq_array { 507 local @Data_Stack; 508 _deep_check(@_); 509} 510 511sub _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 my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; 525 my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; 526 527 push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; 528 $ok = _deep_check($e1,$e2); 529 pop @Data_Stack if $ok; 530 531 last unless $ok; 532 } 533 534 return $ok; 535} 536 537sub _deep_check { 538 my($e1, $e2) = @_; 539 my $tb = Test::More->builder; 540 541 my $ok = 0; 542 543 # Effectively turn %Refs_Seen into a stack. This avoids picking up 544 # 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 my $same_ref = !(!ref $e1 xor !ref $e2); 556 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 $ok = 0; 563 } 564 elsif ( $same_ref and ($e1 eq $e2) ) { 565 $ok = 1; 566 } 567 elsif ( $not_ref ) { 568 push @Data_Stack, { type => '', vals => [$e1, $e2] }; 569 $ok = 0; 570 } 571 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 push @Data_Stack, { type => $type, vals => [$e1, $e2] }; 594 $ok = _deep_check($$e1, $$e2); 595 pop @Data_Stack if $ok; 596 } 597 elsif( $type eq 'SCALAR' ) { 598 push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; 599 $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 616sub _whoa { 617 my($check, $desc) = @_; 618 if( $check ) { 619 die <<WHOA; 620WHOA! $desc 621This should never happen! Please contact the author immediately! 622WHOA 623 } 624} 625 626 627#line 1320 628 629sub eq_hash { 630 local @Data_Stack; 631 return _deep_check(@_); 632} 633 634sub _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 last unless $ok; 655 } 656 657 return $ok; 658} 659 660#line 1377 661 662sub eq_set { 663 my($a1, $a2) = @_; 664 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 # 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 # them. This means eq_set doesn't really work with refs. 680 return eq_array( 681 [grep(ref, @$a1), sort( grep(!ref, @$a1) )], 682 [grep(ref, @$a2), sort( grep(!ref, @$a2) )], 683 ); 684} 685 686#line 1567 687 6881; 689