more.pm

cgi编程更新库

package Test::More;

use 5.004;

use strict;
use Carp;
use Test::Utils;

BEGIN {
    require Test::Simple;
    *TESTOUT = \*Test::Simple::TESTOUT;
    *TESTERR = \*Test::Simple::TESTERR;
}

require Exporter;
use vars qw($VERSION @ISA @EXPORT $TODO);
$VERSION = '0.18';
@ISA    = qw(Exporter);
@EXPORT = qw(ok use_ok require_ok
             is isnt like
             skip todo
             pass fail
             eq_array eq_hash eq_set
             skip
             $TODO
             plan
             can_ok  isa_ok
            );


sub import {
    my($class, $plan, @args) = @_;

    if( defined $plan ) {
        if( $plan eq 'skip_all' ) {
            $Test::Simple::Skip_All = 1;
            my $out = "1..0";
            $out .= " # Skip @args" if @args;
            $out .= "\n";

            my_print *TESTOUT, $out;
            exit(0);
        }
        else {
            Test::Simple->import($plan => @args);
        }
    }
    else {
        Test::Simple->import;
    }

    __PACKAGE__->_export_to_level(1, __PACKAGE__);
}

# 5.004's Exporter doesn't have export_to_level.
sub _export_to_level
{
      my $pkg = shift;
      my $level = shift;
      (undef) = shift;                  # XXX redundant arg
      my $callpkg = caller($level);
      $pkg->export($callpkg, @_);
}


=head1 NAME

Test::More - yet another framework for writing test scripts

=head1 SYNOPSIS

  use Test::More tests => $Num_Tests;
  # or
  use Test::More qw(no_plan);
  # or
  use Test::More skip_all => $reason;

  BEGIN { use_ok( 'Some::Module' ); }
  require_ok( 'Some::Module' );

  # Various ways to say "ok"
  ok($this eq $that, $test_name);

  is  ($this, $that,    $test_name);
  isnt($this, $that,    $test_name);
  like($this, qr/that/, $test_name);

  SKIP: {
      skip $why, $how_many unless $have_some_feature;

      ok( foo(),       $test_name );
      is( foo(42), 23, $test_name );
  };

  TODO: {
      local $TODO = $why;

      ok( foo(),       $test_name );
      is( foo(42), 23, $test_name );
  };

  can_ok($module, @methods);
  isa_ok($object, $class);

  pass($test_name);
  fail($test_name);

  # Utility comparison functions.
  eq_array(\@this, \@that);
  eq_hash(\%this, \%that);
  eq_set(\@this, \@that);

  # UNIMPLEMENTED!!!
  my @status = Test::More::status;

  # UNIMPLEMENTED!!!
  BAIL_OUT($why);


=head1 DESCRIPTION

If you're just getting started writing tests, have a look at
Test::Simple first.  This is a drop in replacement for Test::Simple
which you can switch to once you get the hang of basic testing.

This module provides a very wide range of testing utilities.  Various
ways to say "ok", facilities to skip tests, test future features
and compare complicated data structures.


=head2 I love it when a plan comes together

Before anything else, you need a testing plan.  This basically declares
how many tests your script is going to run to protect against premature
failure.

The prefered way to do this is to declare a plan when you C<use Test::More>.

  use Test::More tests => $Num_Tests;

There are rare cases when you will not know beforehand how many tests
your script is going to run.  In this case, you can declare that you
have no plan.  (Try to avoid using this as it weakens your test.)

  use Test::More qw(no_plan);

In some cases, you'll want to completely skip an entire testing script.

  use Test::More skip_all => $skip_reason;

Your script will declare a skip with the reason why you skipped and
exit immediately with a zero (success).  See L<Test::Harness> for
details.


=head2 Test names

By convention, each test is assigned a number in order.  This is
largely done automatically for you.  However, its often very useful to
assign a name to each test.  Which would you rather see:

  ok 4
  not ok 5
  ok 6

or

  ok 4 - basic multi-variable
  not ok 5 - simple exponential
  ok 6 - force == mass * acceleration

The later gives you some idea of what failed.  It also makes it easier
to find the test in your script, simply search for "simple
exponential".

All test functions take a name argument.  Its optional, but highly
suggested that you use it.


=head2 I'm ok, you're not ok.

The basic purpose of this module is to print out either "ok #" or "not
ok #" depending on if a given test succeeded or failed.  Everything
else is just gravy.

All of the following print "ok" or "not ok" depending on if the test
succeeded or failed.  They all also return true or false,
respectively.

=over 4

=item B<ok>

  ok($this eq $that, $test_name);

This simply evaluates any expression (C<$this eq $that> is just a
simple example) and uses that to determine if the test succeeded or
failed.  A true expression passes, a false one fails.  Very simple.

For example:

    ok( $exp{9} == 81,                   'simple exponential' );
    ok( Film->can('db_Main'),            'set_db()' );
    ok( $p->tests == 4,                  'saw tests' );
    ok( !grep !defined $_, @items,       'items populated' );

(Mnemonic:  "This is ok.")

$test_name is a very short description of the test that will be printed
out.  It makes it very easy to find a test in your script when it fails
and gives others an idea of your intentions.  $test_name is optional,
but we B<very> strongly encourage its use.

Should an ok() fail, it will produce some diagnostics:

    not ok 18 - sufficient mucus
    #     Failed test 18 (foo.t at line 42)

This is actually Test::Simple's ok() routine.

=cut

# We get ok() from Test::Simple's import().

=item B<is>

=item B<isnt>

  is  ( $this, $that, $test_name );
  isnt( $this, $that, $test_name );

Similar to ok(), is() and isnt() compare their two arguments
with C<eq> and C<ne> respectively and use the result of that to
determine if the test succeeded or failed.  So these:

    # Is the ultimate answer 42?
    is( ultimate_answer(), 42,          "Meaning of Life" );

    # $foo isn't empty
    isnt( $foo, '',     "Got some foo" );

are similar to these:

    ok( ultimate_answer() eq 42,        "Meaning of Life" );
    ok( $foo ne '',     "Got some foo" );

(Mnemonic:  "This is that."  "This isn't that.")

So why use these?  They produce better diagnostics on failure.  ok()
cannot know what you are testing for (beyond the name), but is() and
isnt() know what the test was and why it failed.  For example this
test:

    my $foo = 'waffle';  my $bar = 'yarblokos';
    is( $foo, $bar,   'Is foo the same as bar?' );

Will produce something like this:

    not ok 17 - Is foo the same as bar?
    #     Failed test 1 (foo.t at line 139)
    #          got: 'waffle'
    #     expected: 'yarblokos'

So you can figure out what went wrong without rerunning the test.

You are encouraged to use is() and isnt() over ok() where possible,
however do not be tempted to use them to find out if something is
true or false!

  # XXX BAD!  $pope->isa('Catholic') eq 1
  is( $pope->isa('Catholic'), 1,        'Is the Pope Catholic?' );

This does not check if C<$pope->isa('Catholic')> is true, it checks if
it returns 1.  Very different.  Similar caveats exist for false and 0.
In these cases, use ok().

  ok( $pope->isa('Catholic') ),         'Is the Pope Catholic?' );

For those grammatical pedants out there, there's an C<isn't()>
function which is an alias of isnt().

=cut

sub is ($$;$) {
    my($this, $that, $name) = @_;

    my $test;
    {
        local $^W = 0;   # so is(undef, undef) works quietly.
        $test = $this eq $that;
    }
    my $ok = @_ == 3 ? ok($test, $name)
                     : ok($test);

    unless( $ok ) {
        $this = defined $this ? "'$this'" : 'undef';
        $that = defined $that ? "'$that'" : 'undef';
        my_print *TESTERR, sprintf <<DIAGNOSTIC, $this, $that;
#          got: %s
#     expected: %s
DIAGNOSTIC

    }

    return $ok;
}

sub isnt ($$;$) {
    my($this, $that, $name) = @_;

    my $test;
    {
        local $^W = 0;   # so isnt(undef, undef) works quietly.
        $test = $this ne $that;
    }

    my $ok = @_ == 3 ? ok($test, $name)
                     : ok($test);

    unless( $ok ) {
        $that = defined $that ? "'$that'" : 'undef';

        my_print *TESTERR, sprintf <<DIAGNOSTIC, $that;
#     it should not be %s
#     but it is.
DIAGNOSTIC

    }

    return $ok;
}

*isn't = \&isnt;


=item B<like>

  like( $this, qr/that/, $test_name );

Similar to ok(), like() matches $this against the regex C<qr/that/>.

So this:

    like($this, qr/that/, 'this is like that');

is similar to:

    ok( $this =~ /that/, 'this is like that');

(Mnemonic "This is like that".)

The second argument is a regular expression.  It may be given as a
regex reference (ie. C<qr//>) or (for better compatibility with older
perls) as a string that looks like a regex (alternative delimiters are
currently not supported):

    like( $this, '/that/', 'this is like that' );

Regex options may be placed on the end (C<'/that/i'>).

Its advantages over ok() are similar to that of is() and isnt().  Better
diagnostics on failure.

=cut

sub like ($$;$) {
    my($this, $regex, $name) = @_;

    my $ok = 0;
    if( ref $regex eq 'Regexp' ) {
        local $^W = 0;
        $ok = @_ == 3 ? ok( $this =~ $regex ? 1 : 0, $name )
                      : ok( $this =~ $regex ? 1 : 0 );
    }
    # Check if it looks like '/foo/i'
    elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) {
        local $^W = 0;
        $ok = @_ == 3 ? ok( $this =~ /(?$opts)$re/ ? 1 : 0, $name )
                      : ok( $this =~ /(?$opts)$re/ ? 1 : 0 );
    }
    else {
        # Can't use fail() here, the call stack will be fucked.
        my $ok = @_ == 3 ? ok(0, $name )
                         : ok(0);

        my_print *TESTERR, <<ERR;
#     '$regex' doesn't look much like a regex to me.  Failing the test.
ERR

        return $ok;
    }

    unless( $ok ) {
        $this = defined $this ? "'$this'" : 'undef';
        my_print *TESTERR, sprintf <<DIAGNOSTIC, $this;
#                   %s
#     doesn't match '$regex'
DIAGNOSTIC

    }

    return $ok;
}

=item B<can_ok>

  can_ok($module, @methods);
  can_ok($object, @methods);

Checks to make sure the $module or $object can do these @methods
(works with functions, too).

    can_ok('Foo', qw(this that whatever));

is almost exactly like saying:

    ok( Foo->can('this') && 
        Foo->can('that') && 
        Foo->can('whatever') 
      );

only without all the typing and with a better interface.  Handy for
quickly testing an interface.

=cut

sub can_ok ($@) {
    my($proto, @methods) = @_;
    my $class= ref $proto || $proto;

    my @nok = ();
    foreach my $method (@methods) {
        my $test = "$class->can('$method')";
        eval $test || push @nok, $method;
    }

    my $name;
    $name = @methods == 1 ? "$class->can($methods[0])" 
                          : "$class->can(...)";
    
    ok( !@nok, $name );

    my_print *TESTERR, map "#     $class->can('$_') failed\n", @nok;

    return !@nok;
}

=item B<isa_ok>

  isa_ok($object, $class);

Checks to see if the given $object->isa($class).  Also checks to make
sure the object was defined in the first place.  Handy for this sort
of thing:

    my $obj = Some::Module->new;
    isa_ok( $obj, 'Some::Module' );

where you'd otherwise have to write

    my $obj = Some::Module->new;
    ok( defined $obj && $obj->isa('Some::Module') );

to safeguard against your test script blowing up.