lib/Test/More.pm

   1 package Test::More;
   2
   3 use strict;
   4
   5
   6 # Special print function to guard against $\ and -l munging.
   7 sub _print (*@) {
   8     my($fh, @args) = @_;
   9
  10     local $\;
  11     print $fh @args;
  12 }
  13
  14 sub print { die "DON'T USE PRINT!  Use _print instead" }
  15
  16
  17 BEGIN {
  18     require Test::Simple;
  19     *TESTOUT = \*Test::Simple::TESTOUT;
  20     *TESTERR = \*Test::Simple::TESTERR;
  21 }
  22
  23 require Exporter;
  24 use vars qw($VERSION @ISA @EXPORT);
  25 $VERSION = '0.07';
  26 @ISA    = qw(Exporter);
  27 @EXPORT = qw(ok use_ok require_ok
  28              is isnt like
  29              skip todo
  30              pass fail
  31              eq_array eq_hash eq_set
  32             );
  33
  34
  35 sub import {
  36     my($class, $plan, @args) = @_;
  37
  38     if( $plan eq 'skip_all' ) {
  39         $Test::Simple::Skip_All = 1;
  40         _print *TESTOUT, "1..0\n";
  41         exit(0);
  42     }
  43     else {
  44         Test::Simple->import($plan => @args);
  45     }
  46
  47     __PACKAGE__->_export_to_level(1, __PACKAGE__);
  48 }
  49
  50 # 5.004's Exporter doesn't have export_to_level.
  51 sub _export_to_level
  52 {
  53       my $pkg = shift;
  54       my $level = shift;
  55       (undef) = shift;                  # XXX redundant arg
  56       my $callpkg = caller($level);
  57       $pkg->export($callpkg, @_);
  58 }
  59
  60
  61 =head1 NAME
  62
  63 Test::More - yet another framework for writing test scripts
  64
  65 =head1 SYNOPSIS
  66
  67   use Test::More tests => $Num_Tests;
  68   # or
  69   use Test::More qw(no_plan);
  70   # or
  71   use Test::More qw(skip_all);
  72
  73   BEGIN { use_ok( 'Some::Module' ); }
  74   require_ok( 'Some::Module' );
  75
  76   # Various ways to say "ok"
  77   ok($this eq $that, $test_name);
  78
  79   is  ($this, $that,    $test_name);
  80   isnt($this, $that,    $test_name);
  81   like($this, qr/that/, $test_name);
  82
  83   skip {                        # UNIMPLEMENTED!!!
  84       ok( foo(),       $test_name );
  85       is( foo(42), 23, $test_name );
  86   } $how_many, $why;
  87
  88   todo {                        # UNIMPLEMENTED!!!
  89       ok( foo(),       $test_name );
  90       is( foo(42), 23, $test_name );
  91   } $how_many, $why;
  92
  93   pass($test_name);
  94   fail($test_name);
  95
  96   # Utility comparison functions.
  97   eq_array(\@this, \@that);
  98   eq_hash(\%this, \%that);
  99   eq_set(\@this, \@that);
 100
 101   # UNIMPLEMENTED!!!
 102   my @status = Test::More::status;
 103
 104
 105 =head1 DESCRIPTION
 106
 107 If you're just getting started writing tests, have a look at
 108 Test::Simple first.
 109
 110 This module provides a very wide range of testing utilities.  Various
 111 ways to say "ok", facilities to skip tests, test future features
 112 and compare complicated data structures.
 113
 114
 115 =head2 I love it when a plan comes together
 116
 117 Before anything else, you need a testing plan.  This basically declares
 118 how many tests your script is going to run to protect against premature
 119 failure.
 120
 121 The prefered way to do this is to declare a plan when you C<use Test::More>.
 122
 123   use Test::More tests => $Num_Tests;
 124
 125 There are rare cases when you will not know beforehand how many tests
 126 your script is going to run.  In this case, you can declare that you
 127 have no plan.  (Try to avoid using this as it weakens your test.)
 128
 129   use Test::More qw(no_plan);
 130
 131 In some cases, you'll want to completely skip an entire testing script.
 132
 133   use Test::More qw(skip_all);
 134
 135 Your script will declare a skip and exit immediately with a zero
 136 (success).  L<Test::Harness> for details.
 137
 138
 139 =head2 Test names
 140
 141 By convention, each test is assigned a number in order.  This is
 142 largely done automatically for you.  However, its often very useful to
 143 assign a name to each test.  Which would you rather see:
 144
 145   ok 4
 146   not ok 5
 147   ok 6
 148
 149 or
 150
 151   ok 4 - basic multi-variable
 152   not ok 5 - simple exponential
 153   ok 6 - force == mass * acceleration
 154
 155 The later gives you some idea of what failed.  It also makes it easier
 156 to find the test in your script, simply search for "simple
 157 exponential".
 158
 159 All test functions take a name argument.  Its optional, but highly
 160 suggested that you use it.
 161
 162
 163 =head2 I'm ok, you're not ok.
 164
 165 The basic purpose of this module is to print out either "ok #" or "not
 166 ok #" depending on if a given test succeeded or failed.  Everything
 167 else is just gravy.
 168
 169 All of the following print "ok" or "not ok" depending on if the test
 170 succeeded or failed.  They all also return true or false,
 171 respectively.
 172
 173 =over 4
 174
 175 =item B<ok>
 176
 177   ok($this eq $that, $test_name);
 178
 179 This simply evaluates any expression (C<$this eq $that> is just a
 180 simple example) and uses that to determine if the test succeeded or
 181 failed.  A true expression passes, a false one fails.  Very simple.
 182
 183 For example:
 184
 185     ok( $exp{9} == 81,                   'simple exponential' );
 186     ok( Film->can('db_Main'),            'set_db()' );
 187     ok( $p->tests == 4,                  'saw tests' );
 188     ok( !grep !defined $_, @items,       'items populated' );
 189
 190 (Mnemonic:  "This is ok.")
 191
 192 $test_name is a very short description of the test that will be printed
 193 out.  It makes it very easy to find a test in your script when it fails
 194 and gives others an idea of your intentions.  $test_name is optional,
 195 but we B<very> strongly encourage its use.
 196
 197 Should an ok() fail, it will produce some diagnostics:
 198
 199     not ok 18 - sufficient mucus
 200     #     Failed test 18 (foo.t at line 42)
 201
 202 This is actually Test::Simple's ok() routine.
 203
 204 =cut
 205
 206 # We get ok() from Test::Simple's import().
 207
 208 =item B<is>
 209
 210 =item B<isnt>
 211
 212   is  ( $this, $that, $test_name );
 213   isnt( $this, $that, $test_name );
 214
 215 Similar to ok(), is() and isnt() compare their two arguments with
 216 C<eq> and C<ne> respectively and use the result of that to determine
 217 if the test succeeded or failed.  So these:
 218
 219     # Is the ultimate answer 42?
 220     is( ultimate_answer(), 42,          "Meaning of Life" );
 221
 222     # $foo isn't empty
 223     isnt( $foo, '',     "Got some foo" );
 224
 225 are similar to these:
 226
 227     ok( ultimate_answer() eq 42,        "Meaning of Life" );
 228     ok( $foo ne '',     "Got some foo" );
 229
 230 (Mnemonic:  "This is that."  "This isn't that.")
 231
 232 So why use these?  They produce better diagnostics on failure.  ok()
 233 cannot know what you are testing for (beyond the name), but is() and
 234 isnt() know what the test was and why it failed.  For example this
 235  test:
 236
 237     my $foo = 'waffle';  my $bar = 'yarblokos';
 238     is( $foo, $bar,   'Is foo the same as bar?' );
 239
 240 Will produce something like this:
 241
 242     not ok 17 - Is foo the same as bar?
 243     #     Failed test 1 (foo.t at line 139)
 244     #          got: 'waffle'
 245     #     expected: 'yarblokos'
 246
 247 So you can figure out what went wrong without rerunning the test.
 248
 249 You are encouraged to use is() and isnt() over ok() where possible,
 250 however do not be tempted to use them to find out if something is
 251 true or false!
 252
 253   # XXX BAD!  $pope->isa('Catholic') eq 1
 254   is( $pope->isa('Catholic'), 1,        'Is the Pope Catholic?' );
 255
 256 This does not check if C<$pope->isa('Catholic')> is true, it checks if
 257 it returns 1.  Very different.  Similar caveats exist for false and 0.
 258 In these cases, use ok().
 259
 260   ok( $pope->isa('Catholic') ),         'Is the Pope Catholic?' );
 261
 262 For those grammatical pedants out there, there's an isn't() function
 263 which is an alias of isnt().
 264
 265 =cut
 266
 267 sub is ($$;$) {
 268     my($this, $that, $name) = @_;
 269
 270     my $ok = @_ == 3 ? ok($this eq $that, $name)
 271                      : ok($this eq $that);
 272
 273     unless( $ok ) {
 274         _print *TESTERR, <<DIAGNOSTIC;
 275 #          got: '$this'
 276 #     expected: '$that'
 277 DIAGNOSTIC
 278
 279     }
 280
 281     return $ok;
 282 }
 283
 284 sub isnt ($$;$) {
 285     my($this, $that, $name) = @_;
 286
 287     my $ok = @_ == 3 ? ok($this ne $that, $name)
 288                      : ok($this ne $that);
 289
 290     unless( $ok ) {
 291         _print *TESTERR, <<DIAGNOSTIC;
 292 #     it should not be '$that'
 293 #     but it is.
 294 DIAGNOSTIC
 295
 296     }
 297
 298     return $ok;
 299 }
 300
 301 *isn't = \&isnt;
 302
 303
 304 =item B<like>
 305
 306   like( $this, qr/that/, $test_name );
 307
 308 Similar to ok(), like() matches $this against the regex C<qr/that/>.
 309
 310 So this:
 311
 312     like($this, qr/that/, 'this is like that');
 313
 314 is similar to:
 315
 316     ok( $this =~ /that/, 'this is like that');
 317
 318 (Mnemonic "This is like that".)
 319
 320 The second argument is a regular expression.  It may be given as a
 321 regex reference (ie. qr//) or (for better compatibility with older
 322 perls) as a string that looks like a regex (alternative delimiters are
 323 currently not supported):
 324
 325     like( $this, '/that/', 'this is like that' );
 326
 327 Regex options may be placed on the end (C<'/that/i'>).
 328
 329 Its advantages over ok() are similar to that of is() and isnt().  Better
 330 diagnostics on failure.
 331
 332 =cut
 333
 334 sub like ($$;$) {
 335     my($this, $regex, $name) = @_;
 336
 337     my $ok = 0;
 338     if( ref $regex eq 'Regexp' ) {
 339         $ok = @_ == 3 ? ok( $this =~ $regex ? 1 : 0, $name )
 340                       : ok( $this =~ $regex ? 1 : 0 );
 341     }
 342     # Check if it looks like '/foo/i'
 343     elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) {
 344         $ok = @_ == 3 ? ok( $this =~ /(?$opts)$re/ ? 1 : 0, $name )
 345                       : ok( $this =~ /(?$opts)$re/ ? 1 : 0 );
 346     }
 347     else {
 348         # Can't use fail() here, the call stack will be fucked.
 349         my $ok = @_ == 3 ? ok(0, $name )
 350                          : ok(0);
 351
 352         _print *TESTERR, <<ERR;
 353 #     '$regex' doesn't look much like a regex to me.  Failing the test.
 354 ERR
 355
 356         return $ok;
 357     }
 358
 359     unless( $ok ) {
 360         _print *TESTERR, <<DIAGNOSTIC;
 361 #                   '$this'
 362 #     doesn't match '$regex'
 363 DIAGNOSTIC
 364
 365     }
 366
 367     return $ok;
 368 }
 369
 370 =item B<pass>
 371
 372 =item B<fail>
 373
 374   pass($test_name);
 375   fail($test_name);
 376
 377 Sometimes you just want to say that the tests have passed.  Usually
 378 the case is you've got some complicated condition that is difficult to
 379 wedge into an ok().  In this case, you can simply use pass() (to
 380 declare the test ok) or fail (for not ok).  They are synonyms for
 381 ok(1) and ok(0).
 382
 383 Use these very, very, very sparingly.
 384
 385 =cut
 386
 387 sub pass ($) {
 388     my($name) = @_;
 389     return @_ == 1 ? ok(1, $name)
 390                    : ok(1);
 391 }
 392
 393 sub fail ($) {
 394     my($name) = @_;
 395     return @_ == 1 ? ok(0, $name)
 396                    : ok(0);
 397 }
 398
 399 =back
 400
 401 =head2 Module tests
 402
 403 You usually want to test if the module you're testing loads ok, rather
 404 than just vomiting if its load fails.  For such purposes we have
 405 C<use_ok> and C<require_ok>.
 406
 407 =over 4
 408
 409 =item B<use_ok>
 410
 411 =item B<require_ok>
 412
 413    BEGIN { use_ok($module); }
 414    require_ok($module);
 415
 416 These simply use or require the given $module and test to make sure
 417 the load happened ok.  Its recommended that you run use_ok() inside a
 418 BEGIN block so its functions are exported at compile-time and
 419 prototypes are properly honored.
 420
 421 =cut
 422
 423 sub use_ok ($) {
 424     my($module) = shift;
 425
 426     my $pack = caller;
 427
 428     eval <<USE;
 429 package $pack;
 430 require $module;
 431 $module->import;
 432 USE
 433
 434     my $ok = ok( !$@, "use $module;" );
 435
 436     unless( $ok ) {
 437         _print *TESTERR, <<DIAGNOSTIC;
 438 #     Tried to use '$module'.
 439 #     Error:  $@
 440 DIAGNOSTIC
 441
 442     }
 443
 444     return $ok;
 445 }
 446
 447
 448 sub require_ok ($) {
 449     my($module) = shift;
 450
 451     my $pack = caller;
 452
 453     eval <<REQUIRE;
 454 package $pack;
 455 require $module;
 456 REQUIRE
 457
 458     my $ok = ok( !$@, "require $module;" );
 459
 460     unless( $ok ) {
 461         _print *TESTERR, <<DIAGNOSTIC;
 462 #     Tried to require '$module'.
 463 #     Error:  $@
 464 DIAGNOSTIC
 465
 466     }
 467
 468     return $ok;
 469 }
 470
 471
 472 =head2 Conditional tests
 473
 474 Sometimes running a test under certain conditions will cause the
 475 test script to die.  A certain function or method isn't implemented
 476 (such as fork() on MacOS), some resource isn't available (like a
 477 net connection) or a module isn't available.  In these cases its
 478 necessary to skip test, or declare that they are supposed to fail
 479 but will work in the future (a todo test).
 480
 481 For more details on skip and todo tests, L<Test::Harness>.
 482
 483 =over 4
 484
 485 =item B<skip>   * UNIMPLEMENTED *
 486
 487   skip BLOCK $how_many, $why, $if;
 488
 489 B<NOTE> Should that be $if or $unless?
 490
 491 This declares a block of tests to skip, why and under what conditions
 492 to skip them.  An example is the easiest way to illustrate:
 493
 494     skip {
 495         ok( head("http://www.foo.com"),     "www.foo.com is alive" );
 496         ok( head("http://www.foo.com/bar"), "  and has bar" );
 497     } 2, "LWP::Simple not installed",
 498     !eval { require LWP::Simple;  LWP::Simple->import;  1 };
 499
 500 The $if condition is optional, but $why is not.
 501
 502 =cut
 503
 504 sub skip {
 505     die "skip() is UNIMPLEMENTED!";
 506 }
 507
 508 =item B<todo>  * UNIMPLEMENTED *
 509
 510   todo BLOCK $how_many, $why;
 511   todo BLOCK $how_many, $why, $until;
 512
 513 Declares a block of tests you expect to fail and why.  Perhaps its
 514 because you haven't fixed a bug:
 515
 516   todo { is( $Gravitational_Constant, 0 ) }  1,
 517     "Still tinkering with physics --God";
 518
 519 If you have a set of functionality yet to implement, you can make the
 520 whole suite dependent on that new feature.
 521
 522   todo {
 523       $pig->takeoff;
 524       ok( $pig->altitude > 0 );
 525       ok( $pig->mach > 2 );
 526       ok( $pig->serve_peanuts );
 527   } 1, "Pigs are still safely grounded",
 528   Pigs->can('fly');
 529
 530 =cut
 531
 532 sub todo {
 533     die "todo() is UNIMPLEMENTED!";
 534 }
 535
 536 =head2 Comparision functions
 537
 538 Not everything is a simple eq check or regex.  There are times you
 539 need to see if two arrays are equivalent, for instance.  For these
 540 instances, Test::More provides a handful of useful functions.
 541
 542 B<NOTE> These are NOT well-tested on circular references.  Nor am I
 543 quite sure what will happen with filehandles.
 544
 545 =over 4
 546
 547 =item B<eq_array>
 548
 549   eq_array(\@this, \@that);
 550
 551 Checks if two arrays are equivalent.  This is a deep check, so
 552 multi-level structures are handled correctly.
 553
 554 =cut
 555
 556 #'#
 557 sub eq_array  {
 558     my($a1, $a2) = @_;
 559     return 0 unless @$a1 == @$a2;
 560     return 1 if $a1 eq $a2;
 561
 562     my $ok = 1;
 563     for (0..$#{$a1}) {
 564         my($e1,$e2) = ($a1->[$_], $a2->[$_]);
 565         $ok = _deep_check($e1,$e2);
 566         last unless $ok;
 567     }
 568     return $ok;
 569 }
 570
 571 sub _deep_check {
 572     my($e1, $e2) = @_;
 573     my $ok = 0;
 574
 575     if($e1 eq $e2) {
 576         $ok = 1;
 577     }
 578     else {
 579         if( UNIVERSAL::isa($e1, 'ARRAY') and
 580             UNIVERSAL::isa($e2, 'ARRAY') )
 581         {
 582             $ok = eq_array($e1, $e2);
 583         }
 584         elsif( UNIVERSAL::isa($e1, 'HASH') and
 585                UNIVERSAL::isa($e2, 'HASH') )
 586         {
 587             $ok = eq_hash($e1, $e2);
 588         }
 589         else {
 590             $ok = 0;
 591         }
 592     }
 593     return $ok;
 594 }
 595
 596
 597 =item B<eq_hash>
 598
 599   eq_hash(\%this, \%that);
 600
 601 Determines if the two hashes contain the same keys and values.  This
 602 is a deep check.
 603
 604 =cut
 605
 606 sub eq_hash {
 607     my($a1, $a2) = @_;
 608     return 0 unless keys %$a1 == keys %$a2;
 609     return 1 if $a1 eq $a2;
 610
 611     my $ok = 1;
 612     foreach my $k (keys %$a1) {
 613         my($e1, $e2) = ($a1->{$k}, $a2->{$k});
 614         $ok = _deep_check($e1, $e2);
 615         last unless $ok;
 616     }
 617
 618     return $ok;
 619 }
 620
 621 =item B<eq_set>
 622
 623   eq_set(\@this, \@that);
 624
 625 Similar to eq_array(), except the order of the elements is B<not>
 626 important.  This is a deep check, but the irrelevancy of order only
 627 applies to the top level.
 628
 629 =cut
 630
 631 # We must make sure that references are treated neutrally.  It really
 632 # doesn't matter how we sort them, as long as both arrays are sorted
 633 # with the same algorithm.
 634 sub _bogus_sort { ref $a ? 0 : $a cmp $b }
 635
 636 sub eq_set  {
 637     my($a1, $a2) = @_;
 638     return 0 unless @$a1 == @$a2;
 639
 640     # There's faster ways to do this, but this is easiest.
 641     return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] );
 642 }
 643
 644
 645 =back
 646
 647 =head1 BUGS and CAVEATS
 648
 649 The eq_* family have some caveats.
 650
 651 todo() and skip() are unimplemented.
 652
 653 The no_plan feature depends on new Test::Harness feature.  If you're going
 654 to distribute tests that use no_plan your end-users will have to upgrade
 655 Test::Harness to the latest one on CPAN.
 656
 657 =head1 AUTHOR
 658
 659 Michael G Schwern <schwern@pobox.com> with much inspiration from
 660 Joshua Pritikin's Test module and lots of discussion with Barrie
 661 Slaymaker and the perl-qa gang.
 662
 663
 664 =head1 HISTORY
 665
 666 This is a case of convergent evolution with Joshua Pritikin's Test
 667 module.  I was actually largely unware of its existance when I'd first
 668 written my own ok() routines.  This module exists because I can't
 669 figure out how to easily wedge test names into Test's interface (along
 670 with a few other problems).
 671
 672 The goal here is to have a testing utility that's simple to learn,
 673 quick to use and difficult to trip yourself up with while still
 674 providing more flexibility than the existing Test.pm.  As such, the
 675 names of the most common routines are kept tiny, special cases and
 676 magic side-effects are kept to a minimum.  WYSIWYG.
 677
 678
 679 =head1 SEE ALSO
 680
 681 L<Test::Simple> if all this confuses you and you just want to write
 682 some tests.  You can upgrade to Test::More later (its forward
 683 compatible).
 684
 685 L<Test> for a similar testing module.
 686
 687 L<Test::Harness> for details on how your test results are interpreted
 688 by Perl.
 689
 690 L<Test::Unit> describes a very featureful unit testing interface.
 691
 692 L<Pod::Tests> shows the idea of embedded testing.
 693
 694 L<SelfTest> is another approach to embedded testing.
 695
 696 =cut
 697
 698 1;