inc/Test/More.pm

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