[Summary view] [Print] [Text view]

   1  package Test::More;
   2  
   3  use 5.004;
   4  
   5  use 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.
  11  sub _carp {
  12      my($file, $line) = (caller(1))[1,2];
  13      warn @_, " at $file line $line\n";
  14  }
  15  
  16  
  17  
  18  use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
  19  $VERSION = '0.72';
  20  $VERSION = eval $VERSION;    # make the alpha version come out as a number
  21  
  22  use 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  =head1 NAME
  39  
  40  Test::More - yet another framework for writing test scripts
  41  
  42  =head1 SYNOPSIS
  43  
  44    use Test::More tests => 23;
  45    # or
  46    use Test::More qw(no_plan);
  47    # or
  48    use Test::More skip_all => $reason;
  49  
  50    BEGIN { use_ok( 'Some::Module' ); }
  51    require_ok( 'Some::Module' );
  52  
  53    # Various ways to say "ok"
  54    ok($got eq $expected, $test_name);
  55  
  56    is  ($got, $expected, $test_name);
  57    isnt($got, $expected, $test_name);
  58  
  59    # Rather than print STDERR "# here's what went wrong\n"
  60    diag("here's what went wrong");
  61  
  62    like  ($got, qr/expected/, $test_name);
  63    unlike($got, qr/expected/, $test_name);
  64  
  65    cmp_ok($got, '==', $expected, $test_name);
  66  
  67    is_deeply($got_complex_structure, $expected_complex_structure, $test_name);
  68  
  69    SKIP: {
  70        skip $why, $how_many unless $have_some_feature;
  71  
  72        ok( foo(),       $test_name );
  73        is( foo(42), 23, $test_name );
  74    };
  75  
  76    TODO: {
  77        local $TODO = $why;
  78  
  79        ok( foo(),       $test_name );
  80        is( foo(42), 23, $test_name );
  81    };
  82  
  83    can_ok($module, @methods);
  84    isa_ok($object, $class);
  85  
  86    pass($test_name);
  87    fail($test_name);
  88  
  89    BAIL_OUT($why);
  90  
  91    # UNIMPLEMENTED!!!
  92    my @status = Test::More::status;
  93  
  94  
  95  =head1 DESCRIPTION
  96  
  97  B<STOP!> If you're just getting started writing tests, have a look at
  98  Test::Simple first.  This is a drop in replacement for Test::Simple
  99  which you can switch to once you get the hang of basic testing.
 100  
 101  The purpose of this module is to provide a wide range of testing
 102  utilities.  Various ways to say "ok" with better diagnostics,
 103  facilities to skip tests, test future features and compare complicated
 104  data structures.  While you can do almost anything with a simple
 105  C<ok()> function, it doesn't provide good diagnostic output.
 106  
 107  
 108  =head2 I love it when a plan comes together
 109  
 110  Before anything else, you need a testing plan.  This basically declares
 111  how many tests your script is going to run to protect against premature
 112  failure.
 113  
 114  The preferred way to do this is to declare a plan when you C<use Test::More>.
 115  
 116    use Test::More tests => 23;
 117  
 118  There are rare cases when you will not know beforehand how many tests
 119  your script is going to run.  In this case, you can declare that you
 120  have no plan.  (Try to avoid using this as it weakens your test.)
 121  
 122    use Test::More qw(no_plan);
 123  
 124  B<NOTE>: using no_plan requires a Test::Harness upgrade else it will
 125  think everything has failed.  See L<CAVEATS and NOTES>).
 126  
 127  In some cases, you'll want to completely skip an entire testing script.
 128  
 129    use Test::More skip_all => $skip_reason;
 130  
 131  Your script will declare a skip with the reason why you skipped and
 132  exit immediately with a zero (success).  See L<Test::Harness> for
 133  details.
 134  
 135  If you want to control what functions Test::More will export, you
 136  have to use the 'import' option.  For example, to import everything
 137  but 'fail', you'd do:
 138  
 139    use Test::More tests => 23, import => ['!fail'];
 140  
 141  Alternatively, you can use the plan() function.  Useful for when you
 142  have to calculate the number of tests.
 143  
 144    use Test::More;
 145    plan tests => keys %Stuff * 3;
 146  
 147  or for deciding between running the tests at all:
 148  
 149    use Test::More;
 150    if( $^O eq 'MacOS' ) {
 151        plan skip_all => 'Test irrelevant on MacOS';
 152    }
 153    else {
 154        plan tests => 42;
 155    }
 156  
 157  =cut
 158  
 159  sub plan {
 160      my $tb = Test::More->builder;
 161  
 162      $tb->plan(@_);
 163  }
 164  
 165  
 166  # This implements "use Test::More 'no_diag'" but the behavior is
 167  # deprecated.
 168  sub import_extra {
 169      my $class = shift;
 170      my $list  = shift;
 171  
 172      my @other = ();
 173      my $idx = 0;
 174      while( $idx <= $#{$list} ) {
 175          my $item = $list->[$idx];
 176  
 177          if( defined $item and $item eq 'no_diag' ) {
 178              $class->builder->no_diag(1);
 179          }
 180          else {
 181              push @other, $item;
 182          }
 183  
 184          $idx++;
 185      }
 186  
 187      @$list = @other;
 188  }
 189  
 190  
 191  =head2 Test names
 192  
 193  By convention, each test is assigned a number in order.  This is
 194  largely done automatically for you.  However, it's often very useful to
 195  assign a name to each test.  Which would you rather see:
 196  
 197    ok 4
 198    not ok 5
 199    ok 6
 200  
 201  or
 202  
 203    ok 4 - basic multi-variable
 204    not ok 5 - simple exponential
 205    ok 6 - force == mass * acceleration
 206  
 207  The later gives you some idea of what failed.  It also makes it easier
 208  to find the test in your script, simply search for "simple
 209  exponential".
 210  
 211  All test functions take a name argument.  It's optional, but highly
 212  suggested that you use it.
 213  
 214  
 215  =head2 I'm ok, you're not ok.
 216  
 217  The basic purpose of this module is to print out either "ok #" or "not
 218  ok #" depending on if a given test succeeded or failed.  Everything
 219  else is just gravy.
 220  
 221  All of the following print "ok" or "not ok" depending on if the test
 222  succeeded or failed.  They all also return true or false,
 223  respectively.
 224  
 225  =over 4
 226  
 227  =item B<ok>
 228  
 229    ok($got eq $expected, $test_name);
 230  
 231  This simply evaluates any expression (C<$got eq $expected> is just a
 232  simple example) and uses that to determine if the test succeeded or
 233  failed.  A true expression passes, a false one fails.  Very simple.
 234  
 235  For example:
 236  
 237      ok( $exp{9} == 81,                   'simple exponential' );
 238      ok( Film->can('db_Main'),            'set_db()' );
 239      ok( $p->tests == 4,                  'saw tests' );
 240      ok( !grep !defined $_, @items,       'items populated' );
 241  
 242  (Mnemonic:  "This is ok.")
 243  
 244  $test_name is a very short description of the test that will be printed
 245  out.  It makes it very easy to find a test in your script when it fails
 246  and gives others an idea of your intentions.  $test_name is optional,
 247  but we B<very> strongly encourage its use.
 248  
 249  Should an ok() fail, it will produce some diagnostics:
 250  
 251      not ok 18 - sufficient mucus
 252      #   Failed test 'sufficient mucus'
 253      #   in foo.t at line 42.
 254  
 255  This is the same as Test::Simple's ok() routine.
 256  
 257  =cut
 258  
 259  sub ok ($;$) {
 260      my($test, $name) = @_;
 261      my $tb = Test::More->builder;
 262  
 263      $tb->ok($test, $name);
 264  }
 265  
 266  =item B<is>
 267  
 268  =item B<isnt>
 269  
 270    is  ( $got, $expected, $test_name );
 271    isnt( $got, $expected, $test_name );
 272  
 273  Similar to ok(), is() and isnt() compare their two arguments
 274  with C<eq> and C<ne> respectively and use the result of that to
 275  determine if the test succeeded or failed.  So these:
 276  
 277      # Is the ultimate answer 42?
 278      is( ultimate_answer(), 42,          "Meaning of Life" );
 279  
 280      # $foo isn't empty
 281      isnt( $foo, '',     "Got some foo" );
 282  
 283  are similar to these:
 284  
 285      ok( ultimate_answer() eq 42,        "Meaning of Life" );
 286      ok( $foo ne '',     "Got some foo" );
 287  
 288  (Mnemonic:  "This is that."  "This isn't that.")
 289  
 290  So why use these?  They produce better diagnostics on failure.  ok()
 291  cannot know what you are testing for (beyond the name), but is() and
 292  isnt() know what the test was and why it failed.  For example this
 293  test:
 294  
 295      my $foo = 'waffle';  my $bar = 'yarblokos';
 296      is( $foo, $bar,   'Is foo the same as bar?' );
 297  
 298  Will produce something like this:
 299  
 300      not ok 17 - Is foo the same as bar?
 301      #   Failed test 'Is foo the same as bar?'
 302      #   in foo.t at line 139.
 303      #          got: 'waffle'
 304      #     expected: 'yarblokos'
 305  
 306  So you can figure out what went wrong without rerunning the test.
 307  
 308  You are encouraged to use is() and isnt() over ok() where possible,
 309  however do not be tempted to use them to find out if something is
 310  true or false!
 311  
 312    # XXX BAD!
 313    is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' );
 314  
 315  This does not check if C<exists $brooklyn{tree}> is true, it checks if
 316  it returns 1.  Very different.  Similar caveats exist for false and 0.
 317  In these cases, use ok().
 318  
 319    ok( exists $brooklyn{tree},    'A tree grows in Brooklyn' );
 320  
 321  For those grammatical pedants out there, there's an C<isn't()>
 322  function which is an alias of isnt().
 323  
 324  =cut
 325  
 326  sub is ($$;$) {
 327      my $tb = Test::More->builder;
 328  
 329      $tb->is_eq(@_);
 330  }
 331  
 332  sub isnt ($$;$) {
 333      my $tb = Test::More->builder;
 334  
 335      $tb->isnt_eq(@_);
 336  }
 337  
 338  *isn't = \&isnt;
 339  
 340  
 341  =item B<like>
 342  
 343    like( $got, qr/expected/, $test_name );
 344  
 345  Similar to ok(), like() matches $got against the regex C<qr/expected/>.
 346  
 347  So this:
 348  
 349      like($got, qr/expected/, 'this is like that');
 350  
 351  is similar to:
 352  
 353      ok( $got =~ /expected/, 'this is like that');
 354  
 355  (Mnemonic "This is like that".)
 356  
 357  The second argument is a regular expression.  It may be given as a
 358  regex reference (i.e. C<qr//>) or (for better compatibility with older
 359  perls) as a string that looks like a regex (alternative delimiters are
 360  currently not supported):
 361  
 362      like( $got, '/expected/', 'this is like that' );
 363  
 364  Regex options may be placed on the end (C<'/expected/i'>).
 365  
 366  Its advantages over ok() are similar to that of is() and isnt().  Better
 367  diagnostics on failure.
 368  
 369  =cut
 370  
 371  sub like ($$;$) {
 372      my $tb = Test::More->builder;
 373  
 374      $tb->like(@_);
 375  }
 376  
 377  
 378  =item B<unlike>
 379  
 380    unlike( $got, qr/expected/, $test_name );
 381  
 382  Works exactly as like(), only it checks if $got B<does not> match the
 383  given pattern.
 384  
 385  =cut
 386  
 387  sub unlike ($$;$) {
 388      my $tb = Test::More->builder;
 389  
 390      $tb->unlike(@_);
 391  }
 392  
 393  
 394  =item B<cmp_ok>
 395  
 396    cmp_ok( $got, $op, $expected, $test_name );
 397  
 398  Halfway between ok() and is() lies cmp_ok().  This allows you to
 399  compare two arguments using any binary perl operator.
 400  
 401      # ok( $got eq $expected );
 402      cmp_ok( $got, 'eq', $expected, 'this eq that' );
 403  
 404      # ok( $got == $expected );
 405      cmp_ok( $got, '==', $expected, 'this == that' );
 406  
 407      # ok( $got && $expected );
 408      cmp_ok( $got, '&&', $expected, 'this && that' );
 409      ...etc...
 410  
 411  Its advantage over ok() is when the test fails you'll know what $got
 412  and $expected were:
 413  
 414      not ok 1
 415      #   Failed test in foo.t at line 12.
 416      #     '23'
 417      #         &&
 418      #     undef
 419  
 420  It's also useful in those cases where you are comparing numbers and
 421  is()'s use of C<eq> will interfere:
 422  
 423      cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );
 424  
 425  =cut
 426  
 427  sub cmp_ok($$$;$) {
 428      my $tb = Test::More->builder;
 429  
 430      $tb->cmp_ok(@_);
 431  }
 432  
 433  
 434  =item B<can_ok>
 435  
 436    can_ok($module, @methods);
 437    can_ok($object, @methods);
 438  
 439  Checks to make sure the $module or $object can do these @methods
 440  (works with functions, too).
 441  
 442      can_ok('Foo', qw(this that whatever));
 443  
 444  is almost exactly like saying:
 445  
 446      ok( Foo->can('this') && 
 447          Foo->can('that') && 
 448          Foo->can('whatever') 
 449        );
 450  
 451  only without all the typing and with a better interface.  Handy for
 452  quickly testing an interface.
 453  
 454  No matter how many @methods you check, a single can_ok() call counts
 455  as one test.  If you desire otherwise, use:
 456  
 457      foreach my $meth (@methods) {
 458          can_ok('Foo', $meth);
 459      }
 460  
 461  =cut
 462  
 463  sub can_ok ($@) {
 464      my($proto, @methods) = @_;
 465      my $class = ref $proto || $proto;
 466      my $tb = Test::More->builder;
 467  
 468      unless( $class ) {
 469          my $ok = $tb->ok( 0, "->can(...)" );
 470          $tb->diag('    can_ok() called with empty class or reference');
 471          return $ok;
 472      }
 473  
 474      unless( @methods ) {
 475          my $ok = $tb->ok( 0, "$class->can(...)" );
 476          $tb->diag('    can_ok() called with no methods');
 477          return $ok;
 478      }
 479  
 480      my @nok = ();
 481      foreach my $method (@methods) {
 482          $tb->_try(sub { $proto->can($method) }) or push @nok, $method;
 483      }
 484  
 485      my $name;
 486      $name = @methods == 1 ? "$class->can('$methods[0]')" 
 487                            : "$class->can(...)";
 488  
 489      my $ok = $tb->ok( !@nok, $name );
 490  
 491      $tb->diag(map "    $class->can('$_') failed\n", @nok);
 492  
 493      return $ok;
 494  }
 495  
 496  =item B<isa_ok>
 497  
 498    isa_ok($object, $class, $object_name);
 499    isa_ok($ref,    $type,  $ref_name);
 500  
 501  Checks to see if the given C<< $object->isa($class) >>.  Also checks to make
 502  sure the object was defined in the first place.  Handy for this sort
 503  of thing:
 504  
 505      my $obj = Some::Module->new;
 506      isa_ok( $obj, 'Some::Module' );
 507  
 508  where you'd otherwise have to write
 509  
 510      my $obj = Some::Module->new;
 511      ok( defined $obj && $obj->isa('Some::Module') );
 512  
 513  to safeguard against your test script blowing up.
 514  
 515  It works on references, too:
 516  
 517      isa_ok( $array_ref, 'ARRAY' );
 518  
 519  The diagnostics of this test normally just refer to 'the object'.  If
 520  you'd like them to be more specific, you can supply an $object_name
 521  (for example 'Test customer').
 522  
 523  =cut
 524  
 525  sub isa_ok ($$;$) {
 526      my($object, $class, $obj_name) = @_;
 527      my $tb = Test::More->builder;
 528  
 529      my $diag;
 530      $obj_name = 'The object' unless defined $obj_name;
 531      my $name = "$obj_name isa $class";
 532      if( !defined $object ) {
 533          $diag = "$obj_name isn't defined";
 534      }
 535      elsif( !ref $object ) {
 536          $diag = "$obj_name isn't a reference";
 537      }
 538      else {
 539          # We can't use UNIVERSAL::isa because we want to honor isa() overrides
 540          my($rslt, $error) = $tb->_try(sub { $object->isa($class) });
 541          if( $error ) {
 542              if( $error =~ /^Can't call method "isa" on unblessed reference/ ) {
 543                  # Its an unblessed reference
 544                  if( !UNIVERSAL::isa($object, $class) ) {
 545                      my $ref = ref $object;
 546                      $diag = "$obj_name isn't a '$class' it's a '$ref'";
 547                  }
 548              } else {
 549                  die <<WHOA;
 550  WHOA! I tried to call ->isa on your object and got some weird error.
 551  Here's the error.
 552  $error
 553  WHOA
 554              }
 555          }
 556          elsif( !$rslt ) {
 557              my $ref = ref $object;
 558              $diag = "$obj_name isn't a '$class' it's a '$ref'";
 559          }
 560      }
 561              
 562        
 563  
 564      my $ok;
 565      if( $diag ) {
 566          $ok = $tb->ok( 0, $name );
 567          $tb->diag("    $diag\n");
 568      }
 569      else {
 570          $ok = $tb->ok( 1, $name );
 571      }
 572  
 573      return $ok;
 574  }
 575  
 576  
 577  =item B<pass>
 578  
 579  =item B<fail>
 580  
 581    pass($test_name);
 582    fail($test_name);
 583  
 584  Sometimes you just want to say that the tests have passed.  Usually
 585  the case is you've got some complicated condition that is difficult to
 586  wedge into an ok().  In this case, you can simply use pass() (to
 587  declare the test ok) or fail (for not ok).  They are synonyms for
 588  ok(1) and ok(0).
 589  
 590  Use these very, very, very sparingly.
 591  
 592  =cut
 593  
 594  sub pass (;$) {
 595      my $tb = Test::More->builder;
 596      $tb->ok(1, @_);
 597  }
 598  
 599  sub fail (;$) {
 600      my $tb = Test::More->builder;
 601      $tb->ok(0, @_);
 602  }
 603  
 604  =back
 605  
 606  
 607  =head2 Module tests
 608  
 609  You usually want to test if the module you're testing loads ok, rather
 610  than just vomiting if its load fails.  For such purposes we have
 611  C<use_ok> and C<require_ok>.
 612  
 613  =over 4
 614  
 615  =item B<use_ok>
 616  
 617     BEGIN { use_ok($module); }
 618     BEGIN { use_ok($module, @imports); }
 619  
 620  These simply use the given $module and test to make sure the load
 621  happened ok.  It's recommended that you run use_ok() inside a BEGIN
 622  block so its functions are exported at compile-time and prototypes are
 623  properly honored.
 624  
 625  If @imports are given, they are passed through to the use.  So this:
 626  
 627     BEGIN { use_ok('Some::Module', qw(foo bar)) }
 628  
 629  is like doing this:
 630  
 631     use Some::Module qw(foo bar);
 632  
 633  Version numbers can be checked like so:
 634  
 635     # Just like "use Some::Module 1.02"
 636     BEGIN { use_ok('Some::Module', 1.02) }
 637  
 638  Don't try to do this:
 639  
 640     BEGIN {
 641         use_ok('Some::Module');
 642  
 643         ...some code that depends on the use...
 644         ...happening at compile time...
 645     }
 646  
 647  because the notion of "compile-time" is relative.  Instead, you want:
 648  
 649    BEGIN { use_ok('Some::Module') }
 650    BEGIN { ...some code that depends on the use... }
 651  
 652  
 653  =cut
 654  
 655  sub use_ok ($;@) {
 656      my($module, @imports) = @_;
 657      @imports = () unless @imports;
 658      my $tb = Test::More->builder;
 659  
 660      my($pack,$filename,$line) = caller;
 661  
 662      local($@,$!,$SIG{__DIE__});   # isolate eval
 663  
 664      if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
 665          # probably a version check.  Perl needs to see the bare number
 666          # for it to work with non-Exporter based modules.
 667          eval <<USE;
 668  package $pack;
 669  use $module $imports[0];
 670  USE
 671      }
 672      else {
 673          eval <<USE;
 674  package $pack;
 675  use $module \@imports;
 676  USE
 677      }
 678  
 679      my $ok = $tb->ok( !$@, "use $module;" );
 680  
 681      unless( $ok ) {
 682          chomp $@;
 683          $@ =~ s{^BEGIN failed--compilation aborted at .*$}
 684                  {BEGIN failed--compilation aborted at $filename line $line.}m;
 685          $tb->diag(<<DIAGNOSTIC);
 686      Tried to use '$module'.
 687      Error:  $@
 688  DIAGNOSTIC
 689  
 690      }
 691  
 692      return $ok;
 693  }
 694  
 695  =item B<require_ok>
 696  
 697     require_ok($module);
 698     require_ok($file);
 699  
 700  Like use_ok(), except it requires the $module or $file.
 701  
 702  =cut
 703  
 704  sub require_ok ($) {
 705      my($module) = shift;
 706      my $tb = Test::More->builder;
 707  
 708      my $pack = caller;
 709  
 710      # Try to deterine if we've been given a module name or file.
 711      # Module names must be barewords, files not.
 712      $module = qq['$module'] unless _is_module_name($module);
 713  
 714      local($!, $@, $SIG{__DIE__}); # isolate eval
 715      local $SIG{__DIE__};
 716      eval <<REQUIRE;
 717  package $pack;
 718  require $module;
 719  REQUIRE
 720  
 721      my $ok = $tb->ok( !$@, "require $module;" );
 722  
 723      unless( $ok ) {
 724          chomp $@;
 725          $tb->diag(<<DIAGNOSTIC);
 726      Tried to require '$module'.
 727      Error:  $@
 728  DIAGNOSTIC
 729  
 730      }
 731  
 732      return $ok;
 733  }
 734  
 735  
 736  sub _is_module_name {
 737      my $module = shift;
 738  
 739      # Module names start with a letter.
 740      # End with an alphanumeric.
 741      # The rest is an alphanumeric or ::
 742      $module =~ s/\b::\b//g;
 743      $module =~ /^[a-zA-Z]\w*$/;
 744  }
 745  
 746  =back
 747  
 748  
 749  =head2 Complex data structures
 750  
 751  Not everything is a simple eq check or regex.  There are times you
 752  need to see if two data structures are equivalent.  For these
 753  instances Test::More provides a handful of useful functions.
 754  
 755  B<NOTE> I'm not quite sure what will happen with filehandles.
 756  
 757  =over 4
 758  
 759  =item B<is_deeply>
 760  
 761    is_deeply( $got, $expected, $test_name );
 762  
 763  Similar to is(), except that if $got and $expected are references, it
 764  does a deep comparison walking each data structure to see if they are
 765  equivalent.  If the two structures are different, it will display the
 766  place where they start differing.
 767  
 768  is_deeply() compares the dereferenced values of references, the
 769  references themselves (except for their type) are ignored.  This means
 770  aspects such as blessing and ties are not considered "different".
 771  
 772  is_deeply() current has very limited handling of function reference
 773  and globs.  It merely checks if they have the same referent.  This may
 774  improve in the future.
 775  
 776  Test::Differences and Test::Deep provide more in-depth functionality
 777  along these lines.
 778  
 779  =cut
 780  
 781  use vars qw(@Data_Stack %Refs_Seen);
 782  my $DNE = bless [], 'Does::Not::Exist';
 783  
 784  sub _dne {
 785      ref $_[0] eq ref $DNE;
 786  }
 787  
 788  
 789  sub is_deeply {
 790      my $tb = Test::More->builder;
 791  
 792      unless( @_ == 2 or @_ == 3 ) {
 793          my $msg = <<WARNING;
 794  is_deeply() takes two or three args, you gave %d.
 795  This usually means you passed an array or hash instead 
 796  of a reference to it
 797  WARNING
 798          chop $msg;   # clip off newline so carp() will put in line/file
 799  
 800          _carp sprintf $msg, scalar @_;
 801  
 802      return $tb->ok(0);
 803      }
 804  
 805      my($got, $expected, $name) = @_;
 806  
 807      $tb->_unoverload_str(\$expected, \$got);
 808  
 809      my $ok;
 810      if( !ref $got and !ref $expected ) {          # neither is a reference
 811          $ok = $tb->is_eq($got, $expected, $name);
 812      }
 813      elsif( !ref $got xor !ref $expected ) {      # one's a reference, one isn't
 814          $ok = $tb->ok(0, $name);
 815      $tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
 816      }
 817      else {                           # both references
 818          local @Data_Stack = ();
 819          if( _deep_check($got, $expected) ) {
 820              $ok = $tb->ok(1, $name);
 821          }
 822          else {
 823              $ok = $tb->ok(0, $name);
 824              $tb->diag(_format_stack(@Data_Stack));
 825          }
 826      }
 827  
 828      return $ok;
 829  }
 830  
 831  sub _format_stack {
 832      my(@Stack) = @_;
 833  
 834      my $var = '$FOO';
 835      my $did_arrow = 0;
 836      foreach my $entry (@Stack) {
 837          my $type = $entry->{type} || '';
 838          my $idx  = $entry->{'idx'};
 839          if( $type eq 'HASH' ) {
 840              $var .= "->" unless $did_arrow++;
 841              $var .= "{$idx}";
 842          }
 843          elsif( $type eq 'ARRAY' ) {
 844              $var .= "->" unless $did_arrow++;
 845              $var .= "[$idx]";
 846          }
 847          elsif( $type eq 'REF' ) {
 848              $var = "\${$var}";
 849          }
 850      }
 851  
 852      my @vals = @{$Stack[-1]{vals}}[0,1];
 853      my @vars = ();
 854      ($vars[0] = $var) =~ s/\$FOO/     \$got/;
 855      ($vars[1] = $var) =~ s/\$FOO/\$expected/;
 856  
 857      my $out = "Structures begin differing at:\n";
 858      foreach my $idx (0..$#vals) {
 859          my $val = $vals[$idx];
 860          $vals[$idx] = !defined $val ? 'undef'          :
 861                        _dne($val)    ? "Does not exist" :
 862                        ref $val      ? "$val"           :
 863                                        "'$val'";
 864      }
 865  
 866      $out .= "$vars[0] = $vals[0]\n";
 867      $out .= "$vars[1] = $vals[1]\n";
 868  
 869      $out =~ s/^/    /msg;
 870      return $out;
 871  }
 872  
 873  
 874  sub _type {
 875      my $thing = shift;
 876  
 877      return '' if !ref $thing;
 878  
 879      for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
 880          return $type if UNIVERSAL::isa($thing, $type);
 881      }
 882  
 883      return '';
 884  }
 885  
 886  =back
 887  
 888  
 889  =head2 Diagnostics
 890  
 891  If you pick the right test function, you'll usually get a good idea of
 892  what went wrong when it failed.  But sometimes it doesn't work out
 893  that way.  So here we have ways for you to write your own diagnostic
 894  messages which are safer than just C<print STDERR>.
 895  
 896  =over 4
 897  
 898  =item B<diag>
 899  
 900    diag(@diagnostic_message);
 901  
 902  Prints a diagnostic message which is guaranteed not to interfere with
 903  test output.  Like C<print> @diagnostic_message is simply concatenated
 904  together.
 905  
 906  Handy for this sort of thing:
 907  
 908      ok( grep(/foo/, @users), "There's a foo user" ) or
 909          diag("Since there's no foo, check that /etc/bar is set up right");
 910  
 911  which would produce:
 912  
 913      not ok 42 - There's a foo user
 914      #   Failed test 'There's a foo user'
 915      #   in foo.t at line 52.
 916      # Since there's no foo, check that /etc/bar is set up right.
 917  
 918  You might remember C<ok() or diag()> with the mnemonic C<open() or
 919  die()>.
 920  
 921  B<NOTE> The exact formatting of the diagnostic output is still
 922  changing, but it is guaranteed that whatever you throw at it it won't
 923  interfere with the test.
 924  
 925  =cut
 926  
 927  sub diag {
 928      my $tb = Test::More->builder;
 929  
 930      $tb->diag(@_);
 931  }
 932  
 933  
 934  =back
 935  
 936  
 937  =head2 Conditional tests
 938  
 939  Sometimes running a test under certain conditions will cause the
 940  test script to die.  A certain function or method isn't implemented
 941  (such as fork() on MacOS), some resource isn't available (like a 
 942  net connection) or a module isn't available.  In these cases it's
 943  necessary to skip tests, or declare that they are supposed to fail
 944  but will work in the future (a todo test).
 945  
 946  For more details on the mechanics of skip and todo tests see
 947  L<Test::Harness>.
 948  
 949  The way Test::More handles this is with a named block.  Basically, a
 950  block of tests which can be skipped over or made todo.  It's best if I
 951  just show you...
 952  
 953  =over 4
 954  
 955  =item B<SKIP: BLOCK>
 956  
 957    SKIP: {
 958        skip $why, $how_many if $condition;
 959  
 960        ...normal testing code goes here...
 961    }
 962  
 963  This declares a block of tests that might be skipped, $how_many tests
 964  there are, $why and under what $condition to skip them.  An example is
 965  the easiest way to illustrate:
 966  
 967      SKIP: {
 968          eval { require HTML::Lint };
 969  
 970          skip "HTML::Lint not installed", 2 if $@;
 971  
 972          my $lint = new HTML::Lint;
 973          isa_ok( $lint, "HTML::Lint" );
 974  
 975          $lint->parse( $html );
 976          is( $lint->errors, 0, "No errors found in HTML" );
 977      }
 978  
 979  If the user does not have HTML::Lint installed, the whole block of
 980  code I<won't be run at all>.  Test::More will output special ok's
 981  which Test::Harness interprets as skipped, but passing, tests.
 982  
 983  It's important that $how_many accurately reflects the number of tests
 984  in the SKIP block so the # of tests run will match up with your plan.
 985  If your plan is C<no_plan> $how_many is optional and will default to 1.
 986  
 987  It's perfectly safe to nest SKIP blocks.  Each SKIP block must have
 988  the label C<SKIP>, or Test::More can't work its magic.
 989  
 990  You don't skip tests which are failing because there's a bug in your
 991  program, or for which you don't yet have code written.  For that you
 992  use TODO.  Read on.
 993  
 994  =cut
 995  
 996  #'#
 997  sub skip {
 998      my($why, $how_many) = @_;
 999      my $tb = Test::More->builder;
1000  
1001      unless( defined $how_many ) {
1002          # $how_many can only be avoided when no_plan is in use.
1003          _carp "skip() needs to know \$how_many tests are in the block"
1004            unless $tb->has_plan eq 'no_plan';
1005          $how_many = 1;
1006      }
1007  
1008      if( defined $how_many and $how_many =~ /\D/ ) {
1009          _carp "skip() was passed a non-numeric number of tests.  Did you get the arguments backwards?";
1010          $how_many = 1;
1011      }
1012  
1013      for( 1..$how_many ) {
1014          $tb->skip($why);
1015      }
1016  
1017      local $^W = 0;
1018      last SKIP;
1019  }
1020  
1021  
1022  =item B<TODO: BLOCK>
1023  
1024      TODO: {
1025          local $TODO = $why if $condition;
1026  
1027          ...normal testing code goes here...
1028      }
1029  
1030  Declares a block of tests you expect to fail and $why.  Perhaps it's
1031  because you haven't fixed a bug or haven't finished a new feature:
1032  
1033      TODO: {
1034          local $TODO = "URI::Geller not finished";
1035  
1036          my $card = "Eight of clubs";
1037          is( URI::Geller->your_card, $card, 'Is THIS your card?' );
1038  
1039          my $spoon;
1040          URI::Geller->bend_spoon;
1041          is( $spoon, 'bent',    "Spoon bending, that's original" );
1042      }
1043  
1044  With a todo block, the tests inside are expected to fail.  Test::More
1045  will run the tests normally, but print out special flags indicating
1046  they are "todo".  Test::Harness will interpret failures as being ok.
1047  Should anything succeed, it will report it as an unexpected success.
1048  You then know the thing you had todo is done and can remove the
1049  TODO flag.
1050  
1051  The nice part about todo tests, as opposed to simply commenting out a
1052  block of tests, is it's like having a programmatic todo list.  You know
1053  how much work is left to be done, you're aware of what bugs there are,
1054  and you'll know immediately when they're fixed.
1055  
1056  Once a todo test starts succeeding, simply move it outside the block.
1057  When the block is empty, delete it.
1058  
1059  B<NOTE>: TODO tests require a Test::Harness upgrade else it will
1060  treat it as a normal failure.  See L<CAVEATS and NOTES>).
1061  
1062  
1063  =item B<todo_skip>
1064  
1065      TODO: {
1066          todo_skip $why, $how_many if $condition;
1067  
1068          ...normal testing code...
1069      }
1070  
1071  With todo tests, it's best to have the tests actually run.  That way
1072  you'll know when they start passing.  Sometimes this isn't possible.
1073  Often a failing test will cause the whole program to die or hang, even
1074  inside an C<eval BLOCK> with and using C<alarm>.  In these extreme
1075  cases you have no choice but to skip over the broken tests entirely.
1076  
1077  The syntax and behavior is similar to a C<SKIP: BLOCK> except the
1078  tests will be marked as failing but todo.  Test::Harness will
1079  interpret them as passing.
1080  
1081  =cut
1082  
1083  sub todo_skip {
1084      my($why, $how_many) = @_;
1085      my $tb = Test::More->builder;
1086  
1087      unless( defined $how_many ) {
1088          # $how_many can only be avoided when no_plan is in use.
1089          _carp "todo_skip() needs to know \$how_many tests are in the block"
1090            unless $tb->has_plan eq 'no_plan';
1091          $how_many = 1;
1092      }
1093  
1094      for( 1..$how_many ) {
1095          $tb->todo_skip($why);
1096      }
1097  
1098      local $^W = 0;
1099      last TODO;
1100  }
1101  
1102  =item When do I use SKIP vs. TODO?
1103  
1104  B<If it's something the user might not be able to do>, use SKIP.
1105  This includes optional modules that aren't installed, running under
1106  an OS that doesn't have some feature (like fork() or symlinks), or maybe
1107  you need an Internet connection and one isn't available.
1108  
1109  B<If it's something the programmer hasn't done yet>, use TODO.  This
1110  is for any code you haven't written yet, or bugs you have yet to fix,
1111  but want to put tests in your testing script (always a good idea).
1112  
1113  
1114  =back
1115  
1116  
1117  =head2 Test control
1118  
1119  =over 4
1120  
1121  =item B<BAIL_OUT>
1122  
1123      BAIL_OUT($reason);
1124  
1125  Indicates to the harness that things are going so badly all testing
1126  should terminate.  This includes the running any additional test scripts.
1127  
1128  This is typically used when testing cannot continue such as a critical
1129  module failing to compile or a necessary external utility not being
1130  available such as a database connection failing.
1131  
1132  The test will exit with 255.
1133  
1134  =cut
1135  
1136  sub BAIL_OUT {
1137      my $reason = shift;
1138      my $tb = Test::More->builder;
1139  
1140      $tb->BAIL_OUT($reason);
1141  }
1142  
1143  =back
1144  
1145  
1146  =head2 Discouraged comparison functions
1147  
1148  The use of the following functions is discouraged as they are not
1149  actually testing functions and produce no diagnostics to help figure
1150  out what went wrong.  They were written before is_deeply() existed
1151  because I couldn't figure out how to display a useful diff of two
1152  arbitrary data structures.
1153  
1154  These functions are usually used inside an ok().
1155  
1156      ok( eq_array(\@got, \@expected) );
1157  
1158  C<is_deeply()> can do that better and with diagnostics.  
1159  
1160      is_deeply( \@got, \@expected );
1161  
1162  They may be deprecated in future versions.
1163  
1164  =over 4
1165  
1166  =item B<eq_array>
1167  
1168    my $is_eq = eq_array(\@got, \@expected);
1169  
1170  Checks if two arrays are equivalent.  This is a deep check, so
1171  multi-level structures are handled correctly.
1172  
1173  =cut
1174  
1175  #'#
1176  sub eq_array {
1177      local @Data_Stack;
1178      _deep_check(@_);
1179  }
1180  
1181  sub _eq_array  {
1182      my($a1, $a2) = @_;
1183  
1184      if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) {
1185          warn "eq_array passed a non-array ref";
1186          return 0;
1187      }
1188  
1189      return 1 if $a1 eq $a2;
1190  
1191      my $ok = 1;
1192      my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
1193      for (0..$max) {
1194          my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
1195          my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
1196  
1197          push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
1198          $ok = _deep_check($e1,$e2);
1199          pop @Data_Stack if $ok;
1200  
1201          last unless $ok;
1202      }
1203  
1204      return $ok;
1205  }
1206  
1207  sub _deep_check {
1208      my($e1, $e2) = @_;
1209      my $tb = Test::More->builder;
1210  
1211      my $ok = 0;
1212  
1213      # Effectively turn %Refs_Seen into a stack.  This avoids picking up
1214      # the same referenced used twice (such as [\$a, \$a]) to be considered
1215      # circular.
1216      local %Refs_Seen = %Refs_Seen;
1217  
1218      {
1219          # Quiet uninitialized value warnings when comparing undefs.
1220          local $^W = 0; 
1221  
1222          $tb->_unoverload_str(\$e1, \$e2);
1223  
1224          # Either they're both references or both not.
1225          my $same_ref = !(!ref $e1 xor !ref $e2);
1226      my $not_ref  = (!ref $e1 and !ref $e2);
1227  
1228          if( defined $e1 xor defined $e2 ) {
1229              $ok = 0;
1230          }
1231          elsif ( _dne($e1) xor _dne($e2) ) {
1232              $ok = 0;
1233          }
1234          elsif ( $same_ref and ($e1 eq $e2) ) {
1235              $ok = 1;
1236          }
1237      elsif ( $not_ref ) {
1238          push @Data_Stack, { type => '', vals => [$e1, $e2] };
1239          $ok = 0;
1240      }
1241          else {
1242              if( $Refs_Seen{$e1} ) {
1243                  return $Refs_Seen{$e1} eq $e2;
1244              }
1245              else {
1246                  $Refs_Seen{$e1} = "$e2";
1247              }
1248  
1249              my $type = _type($e1);
1250              $type = 'DIFFERENT' unless _type($e2) eq $type;
1251  
1252              if( $type eq 'DIFFERENT' ) {
1253                  push @Data_Stack, { type => $type, vals => [$e1, $e2] };
1254                  $ok = 0;
1255              }
1256              elsif( $type eq 'ARRAY' ) {
1257                  $ok = _eq_array($e1, $e2);
1258              }
1259              elsif( $type eq 'HASH' ) {
1260                  $ok = _eq_hash($e1, $e2);
1261              }
1262              elsif( $type eq 'REF' ) {
1263                  push @Data_Stack, { type => $type, vals => [$e1, $e2] };
1264                  $ok = _deep_check($$e1, $$e2);
1265                  pop @Data_Stack if $ok;
1266              }
1267              elsif( $type eq 'SCALAR' ) {
1268                  push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
1269                  $ok = _deep_check($$e1, $$e2);
1270                  pop @Data_Stack if $ok;
1271              }
1272              elsif( $type ) {
1273                  push @Data_Stack, { type => $type, vals => [$e1, $e2] };
1274                  $ok = 0;
1275              }
1276          else {
1277          _whoa(1, "No type in _deep_check");
1278          }
1279          }
1280      }
1281  
1282      return $ok;
1283  }
1284  
1285  
1286  sub _whoa {
1287      my($check, $desc) = @_;
1288      if( $check ) {
1289          die <<WHOA;
1290  WHOA!  $desc
1291  This should never happen!  Please contact the author immediately!
1292  WHOA
1293      }
1294  }
1295  
1296  
1297  =item B<eq_hash>
1298  
1299    my $is_eq = eq_hash(\%got, \%expected);
1300  
1301  Determines if the two hashes contain the same keys and values.  This
1302  is a deep check.
1303  
1304  =cut
1305  
1306  sub eq_hash {
1307      local @Data_Stack;
1308      return _deep_check(@_);
1309  }
1310  
1311  sub _eq_hash {
1312      my($a1, $a2) = @_;
1313  
1314      if( grep !_type($_) eq 'HASH', $a1, $a2 ) {
1315          warn "eq_hash passed a non-hash ref";
1316          return 0;
1317      }
1318  
1319      return 1 if $a1 eq $a2;
1320  
1321      my $ok = 1;
1322      my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
1323      foreach my $k (keys %$bigger) {
1324          my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
1325          my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
1326  
1327          push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
1328          $ok = _deep_check($e1, $e2);
1329          pop @Data_Stack if $ok;
1330  
1331          last unless $ok;
1332      }
1333  
1334      return $ok;
1335  }
1336  
1337  =item B<eq_set>
1338  
1339    my $is_eq = eq_set(\@got, \@expected);
1340  
1341  Similar to eq_array(), except the order of the elements is B<not>
1342  important.  This is a deep check, but the irrelevancy of order only
1343  applies to the top level.
1344  
1345      ok( eq_set(\@got, \@expected) );
1346  
1347  Is better written:
1348  
1349      is_deeply( [sort @got], [sort @expected] );
1350  
1351  B<NOTE> By historical accident, this is not a true set comparison.
1352  While the order of elements does not matter, duplicate elements do.
1353  
1354  B<NOTE> eq_set() does not know how to deal with references at the top
1355  level.  The following is an example of a comparison which might not work:
1356  
1357      eq_set([\1, \2], [\2, \1]);
1358  
1359  Test::Deep contains much better set comparison functions.
1360  
1361  =cut
1362  
1363  sub eq_set  {
1364      my($a1, $a2) = @_;
1365      return 0 unless @$a1 == @$a2;
1366  
1367      # There's faster ways to do this, but this is easiest.
1368      local $^W = 0;
1369  
1370      # It really doesn't matter how we sort them, as long as both arrays are 
1371      # sorted with the same algorithm.
1372      #
1373      # Ensure that references are not accidentally treated the same as a
1374      # string containing the reference.
1375      #
1376      # Have to inline the sort routine due to a threading/sort bug.
1377      # See [rt.cpan.org 6782]
1378      #
1379      # I don't know how references would be sorted so we just don't sort
1380      # them.  This means eq_set doesn't really work with refs.
1381      return eq_array(
1382             [grep(ref, @$a1), sort( grep(!ref, @$a1) )],
1383             [grep(ref, @$a2), sort( grep(!ref, @$a2) )],
1384      );
1385  }
1386  
1387  =back
1388  
1389  
1390  =head2 Extending and Embedding Test::More
1391  
1392  Sometimes the Test::More interface isn't quite enough.  Fortunately,
1393  Test::More is built on top of Test::Builder which provides a single,
1394  unified backend for any test library to use.  This means two test
1395  libraries which both use Test::Builder B<can be used together in the
1396  same program>.
1397  
1398  If you simply want to do a little tweaking of how the tests behave,
1399  you can access the underlying Test::Builder object like so:
1400  
1401  =over 4
1402  
1403  =item B<builder>
1404  
1405      my $test_builder = Test::More->builder;
1406  
1407  Returns the Test::Builder object underlying Test::More for you to play
1408  with.
1409  
1410  
1411  =back
1412  
1413  
1414  =head1 EXIT CODES
1415  
1416  If all your tests passed, Test::Builder will exit with zero (which is
1417  normal).  If anything failed it will exit with how many failed.  If
1418  you run less (or more) tests than you planned, the missing (or extras)
1419  will be considered failures.  If no tests were ever run Test::Builder
1420  will throw a warning and exit with 255.  If the test died, even after
1421  having successfully completed all its tests, it will still be
1422  considered a failure and will exit with 255.
1423  
1424  So the exit codes are...
1425  
1426      0                   all tests successful
1427      255                 test died or all passed but wrong # of tests run
1428      any other number    how many failed (including missing or extras)
1429  
1430  If you fail more than 254 tests, it will be reported as 254.
1431  
1432  B<NOTE>  This behavior may go away in future versions.
1433  
1434  
1435  =head1 CAVEATS and NOTES
1436  
1437  =over 4
1438  
1439  =item Backwards compatibility
1440  
1441  Test::More works with Perls as old as 5.004_05.
1442  
1443  
1444  =item Overloaded objects
1445  
1446  String overloaded objects are compared B<as strings> (or in cmp_ok()'s
1447  case, strings or numbers as appropriate to the comparison op).  This
1448  prevents Test::More from piercing an object's interface allowing
1449  better blackbox testing.  So if a function starts returning overloaded
1450  objects instead of bare strings your tests won't notice the
1451  difference.  This is good.
1452  
1453  However, it does mean that functions like is_deeply() cannot be used to
1454  test the internals of string overloaded objects.  In this case I would
1455  suggest Test::Deep which contains more flexible testing functions for
1456  complex data structures.
1457  
1458  
1459  =item Threads
1460  
1461  Test::More will only be aware of threads if "use threads" has been done
1462  I<before> Test::More is loaded.  This is ok:
1463  
1464      use threads;
1465      use Test::More;
1466  
1467  This may cause problems:
1468  
1469      use Test::More
1470      use threads;
1471  
1472  5.8.1 and above are supported.  Anything below that has too many bugs.
1473  
1474  
1475  =item Test::Harness upgrade
1476  
1477  no_plan and todo depend on new Test::Harness features and fixes.  If
1478  you're going to distribute tests that use no_plan or todo your
1479  end-users will have to upgrade Test::Harness to the latest one on
1480  CPAN.  If you avoid no_plan and TODO tests, the stock Test::Harness
1481  will work fine.
1482  
1483  Installing Test::More should also upgrade Test::Harness.
1484  
1485  =back
1486  
1487  
1488  =head1 HISTORY
1489  
1490  This is a case of convergent evolution with Joshua Pritikin's Test
1491  module.  I was largely unaware of its existence when I'd first
1492  written my own ok() routines.  This module exists because I can't
1493  figure out how to easily wedge test names into Test's interface (along
1494  with a few other problems).
1495  
1496  The goal here is to have a testing utility that's simple to learn,
1497  quick to use and difficult to trip yourself up with while still
1498  providing more flexibility than the existing Test.pm.  As such, the
1499  names of the most common routines are kept tiny, special cases and
1500  magic side-effects are kept to a minimum.  WYSIWYG.
1501  
1502  
1503  =head1 SEE ALSO
1504  
1505  L<Test::Simple> if all this confuses you and you just want to write
1506  some tests.  You can upgrade to Test::More later (it's forward
1507  compatible).
1508  
1509  L<Test> is the old testing module.  Its main benefit is that it has
1510  been distributed with Perl since 5.004_05.
1511  
1512  L<Test::Harness> for details on how your test results are interpreted
1513  by Perl.
1514  
1515  L<Test::Differences> for more ways to test complex data structures.
1516  And it plays well with Test::More.
1517  
1518  L<Test::Class> is like XUnit but more perlish.
1519  
1520  L<Test::Deep> gives you more powerful complex data structure testing.
1521  
1522  L<Test::Unit> is XUnit style testing.
1523  
1524  L<Test::Inline> shows the idea of embedded testing.
1525  
1526  L<Bundle::Test> installs a whole bunch of useful test modules.
1527  
1528  
1529  =head1 AUTHORS
1530  
1531  Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration
1532  from Joshua Pritikin's Test module and lots of help from Barrie
1533  Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and
1534  the perl-qa gang.
1535  
1536  
1537  =head1 BUGS
1538  
1539  See F<http://rt.cpan.org> to report and view bugs.
1540  
1541  
1542  =head1 COPYRIGHT
1543  
1544  Copyright 2001-2002, 2004-2006 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
1545  
1546  This program is free software; you can redistribute it and/or
1547  modify it under the same terms as Perl itself.
1548  
1549  See F<http://www.perl.com/perl/misc/Artistic.html>
1550  
1551  =cut
1552  
1553  1;