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.70'; 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 local($@,$!,$SIG{__DIE__}); # isolate eval 237 238 if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) { 239 # probably a version check. Perl needs to see the bare number 240 # for it to work with non-Exporter based modules. 241 eval <<USE; 242package $pack; 243use $module $imports[0]; 244USE 245 } 246 else { 247 eval <<USE; 248package $pack; 249use $module \@imports; 250USE 251 } 252 253 my $ok = $tb->ok( !$@, "use $module;" ); 254 255 unless( $ok ) { 256 chomp $@; 257 $@ =~ s{^BEGIN failed--compilation aborted at .*$} 258 {BEGIN failed--compilation aborted at $filename line $line.}m; 259 $tb->diag(<<DIAGNOSTIC); 260 Tried to use '$module'. 261 Error: $@ 262DIAGNOSTIC 263 264 } 265 266 return $ok; 267} 268 269#line 702 270 271sub require_ok ($) { 272 my($module) = shift; 273 my $tb = Test::More->builder; 274 275 my $pack = caller; 276 277 # Try to deterine if we've been given a module name or file. 278 # Module names must be barewords, files not. 279 $module = qq['$module'] unless _is_module_name($module); 280 281 local($!, $@, $SIG{__DIE__}); # isolate eval 282 local $SIG{__DIE__}; 283 eval <<REQUIRE; 284package $pack; 285require $module; 286REQUIRE 287 288 my $ok = $tb->ok( !$@, "require $module;" ); 289 290 unless( $ok ) { 291 chomp $@; 292 $tb->diag(<<DIAGNOSTIC); 293 Tried to require '$module'. 294 Error: $@ 295DIAGNOSTIC 296 297 } 298 299 return $ok; 300} 301 302 303sub _is_module_name { 304 my $module = shift; 305 306 # Module names start with a letter. 307 # End with an alphanumeric. 308 # The rest is an alphanumeric or :: 309 $module =~ s/\b::\b//g; 310 $module =~ /^[a-zA-Z]\w*$/; 311} 312 313#line 779 314 315use vars qw(@Data_Stack %Refs_Seen); 316my $DNE = bless [], 'Does::Not::Exist'; 317sub is_deeply { 318 my $tb = Test::More->builder; 319 320 unless( @_ == 2 or @_ == 3 ) { 321 my $msg = <<WARNING; 322is_deeply() takes two or three args, you gave %d. 323This usually means you passed an array or hash instead 324of a reference to it 325WARNING 326 chop $msg; # clip off newline so carp() will put in line/file 327 328 _carp sprintf $msg, scalar @_; 329 330 return $tb->ok(0); 331 } 332 333 my($got, $expected, $name) = @_; 334 335 $tb->_unoverload_str(\$expected, \$got); 336 337 my $ok; 338 if( !ref $got and !ref $expected ) { # neither is a reference 339 $ok = $tb->is_eq($got, $expected, $name); 340 } 341 elsif( !ref $got xor !ref $expected ) { # one's a reference, one isn't 342 $ok = $tb->ok(0, $name); 343 $tb->diag( _format_stack({ vals => [ $got, $expected ] }) ); 344 } 345 else { # both references 346 local @Data_Stack = (); 347 if( _deep_check($got, $expected) ) { 348 $ok = $tb->ok(1, $name); 349 } 350 else { 351 $ok = $tb->ok(0, $name); 352 $tb->diag(_format_stack(@Data_Stack)); 353 } 354 } 355 356 return $ok; 357} 358 359sub _format_stack { 360 my(@Stack) = @_; 361 362 my $var = '$FOO'; 363 my $did_arrow = 0; 364 foreach my $entry (@Stack) { 365 my $type = $entry->{type} || ''; 366 my $idx = $entry->{'idx'}; 367 if( $type eq 'HASH' ) { 368 $var .= "->" unless $did_arrow++; 369 $var .= "{$idx}"; 370 } 371 elsif( $type eq 'ARRAY' ) { 372 $var .= "->" unless $did_arrow++; 373 $var .= "[$idx]"; 374 } 375 elsif( $type eq 'REF' ) { 376 $var = "\${$var}"; 377 } 378 } 379 380 my @vals = @{$Stack[-1]{vals}}[0,1]; 381 my @vars = (); 382 ($vars[0] = $var) =~ s/\$FOO/ \$got/; 383 ($vars[1] = $var) =~ s/\$FOO/\$expected/; 384 385 my $out = "Structures begin differing at:\n"; 386 foreach my $idx (0..$#vals) { 387 my $val = $vals[$idx]; 388 $vals[$idx] = !defined $val ? 'undef' : 389 $val eq $DNE ? "Does not exist" : 390 ref $val ? "$val" : 391 "'$val'"; 392 } 393 394 $out .= "$vars[0] = $vals[0]\n"; 395 $out .= "$vars[1] = $vals[1]\n"; 396 397 $out =~ s/^/ /msg; 398 return $out; 399} 400 401 402sub _type { 403 my $thing = shift; 404 405 return '' if !ref $thing; 406 407 for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) { 408 return $type if UNIVERSAL::isa($thing, $type); 409 } 410 411 return ''; 412} 413 414#line 919 415 416sub diag { 417 my $tb = Test::More->builder; 418 419 $tb->diag(@_); 420} 421 422 423#line 988 424 425#'# 426sub skip { 427 my($why, $how_many) = @_; 428 my $tb = Test::More->builder; 429 430 unless( defined $how_many ) { 431 # $how_many can only be avoided when no_plan is in use. 432 _carp "skip() needs to know \$how_many tests are in the block" 433 unless $tb->has_plan eq 'no_plan'; 434 $how_many = 1; 435 } 436 437 if( defined $how_many and $how_many =~ /\D/ ) { 438 _carp "skip() was passed a non-numeric number of tests. Did you get the arguments backwards?"; 439 $how_many = 1; 440 } 441 442 for( 1..$how_many ) { 443 $tb->skip($why); 444 } 445 446 local $^W = 0; 447 last SKIP; 448} 449 450 451#line 1075 452 453sub todo_skip { 454 my($why, $how_many) = @_; 455 my $tb = Test::More->builder; 456 457 unless( defined $how_many ) { 458 # $how_many can only be avoided when no_plan is in use. 459 _carp "todo_skip() needs to know \$how_many tests are in the block" 460 unless $tb->has_plan eq 'no_plan'; 461 $how_many = 1; 462 } 463 464 for( 1..$how_many ) { 465 $tb->todo_skip($why); 466 } 467 468 local $^W = 0; 469 last TODO; 470} 471 472#line 1128 473 474sub BAIL_OUT { 475 my $reason = shift; 476 my $tb = Test::More->builder; 477 478 $tb->BAIL_OUT($reason); 479} 480 481#line 1167 482 483#'# 484sub eq_array { 485 local @Data_Stack; 486 _deep_check(@_); 487} 488 489sub _eq_array { 490 my($a1, $a2) = @_; 491 492 if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) { 493 warn "eq_array passed a non-array ref"; 494 return 0; 495 } 496 497 return 1 if $a1 eq $a2; 498 499 my $ok = 1; 500 my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; 501 for (0..$max) { 502 my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; 503 my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; 504 505 push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; 506 $ok = _deep_check($e1,$e2); 507 pop @Data_Stack if $ok; 508 509 last unless $ok; 510 } 511 512 return $ok; 513} 514 515sub _deep_check { 516 my($e1, $e2) = @_; 517 my $tb = Test::More->builder; 518 519 my $ok = 0; 520 521 # Effectively turn %Refs_Seen into a stack. This avoids picking up 522 # the same referenced used twice (such as [\$a, \$a]) to be considered 523 # circular. 524 local %Refs_Seen = %Refs_Seen; 525 526 { 527 # Quiet uninitialized value warnings when comparing undefs. 528 local $^W = 0; 529 530 $tb->_unoverload_str(\$e1, \$e2); 531 532 # Either they're both references or both not. 533 my $same_ref = !(!ref $e1 xor !ref $e2); 534 my $not_ref = (!ref $e1 and !ref $e2); 535 536 if( defined $e1 xor defined $e2 ) { 537 $ok = 0; 538 } 539 elsif ( $e1 == $DNE xor $e2 == $DNE ) { 540 $ok = 0; 541 } 542 elsif ( $same_ref and ($e1 eq $e2) ) { 543 $ok = 1; 544 } 545 elsif ( $not_ref ) { 546 push @Data_Stack, { type => '', vals => [$e1, $e2] }; 547 $ok = 0; 548 } 549 else { 550 if( $Refs_Seen{$e1} ) { 551 return $Refs_Seen{$e1} eq $e2; 552 } 553 else { 554 $Refs_Seen{$e1} = "$e2"; 555 } 556 557 my $type = _type($e1); 558 $type = 'DIFFERENT' unless _type($e2) eq $type; 559 560 if( $type eq 'DIFFERENT' ) { 561 push @Data_Stack, { type => $type, vals => [$e1, $e2] }; 562 $ok = 0; 563 } 564 elsif( $type eq 'ARRAY' ) { 565 $ok = _eq_array($e1, $e2); 566 } 567 elsif( $type eq 'HASH' ) { 568 $ok = _eq_hash($e1, $e2); 569 } 570 elsif( $type eq 'REF' ) { 571 push @Data_Stack, { type => $type, vals => [$e1, $e2] }; 572 $ok = _deep_check($$e1, $$e2); 573 pop @Data_Stack if $ok; 574 } 575 elsif( $type eq 'SCALAR' ) { 576 push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; 577 $ok = _deep_check($$e1, $$e2); 578 pop @Data_Stack if $ok; 579 } 580 elsif( $type ) { 581 push @Data_Stack, { type => $type, vals => [$e1, $e2] }; 582 $ok = 0; 583 } 584 else { 585 _whoa(1, "No type in _deep_check"); 586 } 587 } 588 } 589 590 return $ok; 591} 592 593 594sub _whoa { 595 my($check, $desc) = @_; 596 if( $check ) { 597 die <<WHOA; 598WHOA! $desc 599This should never happen! Please contact the author immediately! 600WHOA 601 } 602} 603 604 605#line 1298 606 607sub eq_hash { 608 local @Data_Stack; 609 return _deep_check(@_); 610} 611 612sub _eq_hash { 613 my($a1, $a2) = @_; 614 615 if( grep !_type($_) eq 'HASH', $a1, $a2 ) { 616 warn "eq_hash passed a non-hash ref"; 617 return 0; 618 } 619 620 return 1 if $a1 eq $a2; 621 622 my $ok = 1; 623 my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; 624 foreach my $k (keys %$bigger) { 625 my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; 626 my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; 627 628 push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; 629 $ok = _deep_check($e1, $e2); 630 pop @Data_Stack if $ok; 631 632 last unless $ok; 633 } 634 635 return $ok; 636} 637 638#line 1355 639 640sub eq_set { 641 my($a1, $a2) = @_; 642 return 0 unless @$a1 == @$a2; 643 644 # There's faster ways to do this, but this is easiest. 645 local $^W = 0; 646 647 # It really doesn't matter how we sort them, as long as both arrays are 648 # sorted with the same algorithm. 649 # 650 # Ensure that references are not accidentally treated the same as a 651 # string containing the reference. 652 # 653 # Have to inline the sort routine due to a threading/sort bug. 654 # See [rt.cpan.org 6782] 655 # 656 # I don't know how references would be sorted so we just don't sort 657 # them. This means eq_set doesn't really work with refs. 658 return eq_array( 659 [grep(ref, @$a1), sort( grep(!ref, @$a1) )], 660 [grep(ref, @$a2), sort( grep(!ref, @$a2) )], 661 ); 662} 663 664#line 1545 665 6661; 667