File Coverage

blib/lib/Test/Functional.pm

Criterion	Covered	Total	%
statement	83	102	81.3
branch	15	34	44.1
condition	7	21	33.3
subroutine	29	33	87.8
pod	14	14	100.0
total	148	204	72.5

package Test::Functional;

use warnings FATAL => 'all';
use strict;

our $VERSION = '0.06';

=head1 NAME

Test::Functional - Perl tests in a functional style.

=head1 SYNOPSIS

  use Test::Functional;

  # make sure the bomb goes off
  sub explode { die "BOOM" }
  test { explode() } dies, "test-3";

  # implicit and explicit equivalence
  test { 2 * 2 } 4, "test-1";
  test { 2 * 2 } eqv 4, "test-1";

  # test blocks can be as simple or as involved as you want
  test { 3 > 0 } true, "test-4";
  test {
      my $total = 0;
      foreach my $person ($car->occupants) {
          $total += $person->weight
      }
      $total < 600
  } true, "test-5";

  # after the test runs, you also get the result.
  my $horse = test { Horse->new } typeqv "Horse", "test-6";

  # you can make your own comparator functions, or use existing ones.
  use Test::More import => [qw(like)];
  sub islike {
      my ($other) = @_;
      return sub {
          my ($got, $testname) = @_;
          like($got, $other, $testname);
      };
  }
  test { 'caterpillar' } islike(qr/cat/), 'is cat?';

=head1 DESCRIPTION

This modules uses (abuses?) the ability to create new syntax via perl
prototypes to create a testing system focused on functions rather than values.
Tests run blocks of Perl, and use comparator functions to test the output.
Despite being a different way of thinking about tests, it plays well with
L and friends.

=cut
use Data::Compare qw(Compare);
use Scalar::Quote qw(quote);
use Scalar::Util qw(blessed looks_like_number reftype);
use Test::More import => ['is_deeply'];
use Test::Functional::Conf;

use base 'Test::Builder::Module';

=head1 EXPORTS

Since this module is going to be used for test scripts, its methods all export
by default. You can choose which you want using the standard directives:

    # import only eqv
    use Test::Functional tests => 23, import => ['eqv'];

    # import all but notest
    use Test::Functional tests => 23, import => ['!notest'];

=cut
our @EXPORT = (
    qw(test pretest notest group),
    qw(eqv ineqv typeqv dies noop true false isdef isundef),
);

# three global variables: two settings and a stack for test groups
my ($UNSTABLE, $FASTOUT, @STACK);

=head1 CONFIGURE

This package has two settings which can be altered to change performance:

    unstable - run tests which are normally skipped
    fastout  - cause the entire test to end after the first failure

This package can be configured via L or the configure()
function.

=over

=item configure KEY => VALUE, ...

Changes configuration values at run-time.

=cut
sub configure {
    my (%opts) = @_;
    $UNSTABLE  = $opts{unstable} if exists($opts{unstable});
    $FASTOUT   = $opts{fastout} if exists($opts{fastout});
}

configure(
    unstable => Test::Functional::Conf->unstable,
    fastout  => Test::Functional::Conf->fastout,
);

=back

=head1 TEST STRUCTURES

=over

=item B

This is the basic building block of Test::Functional. Each test function
contains an anonymous code block (which is expected to return a scalar
I), a name for the test, and a condition (an optional subroutine to
check the result).

In most cases, a test passes if the code block doesn't die, and if the condition
is true (or absent). There is a special condition I which expects the code
block to die, and fails unless it does so.

Whether the test passes or fails, I returns the value generated by
I.

=cut
sub test(&$;$) {
    return _test(0, @_);
}

=item B

This works like I except that if it fails, it will short-circuit all
testing at the current level. This means that top-level I calls will
halt the entire test if they fail. One obvious example for this is:

    BEGIN { pretest { use Foo::Bar } "test-use" }
    test { Foo::Bar::double(2) } eqv(4), "double(2)";
    test { Foo::Bar::double(3) } eqv(6), "double(3)";
    test { Foo::Bar::double(4) } eqv(8), "double(4)";

If the C fails, the information that all the other tests are
failing is less useful. I can also be combined with I
(described later) to short-circuit a small set of related tests.

=cut
sub pretest(&$;$) {
    return _test(1, @_);
}

=item B

This is has exactly the same semantics as I; the only difference is that
it normally doesn't run. If C<< Test::Functional::Conf->unstable >> is true,
then this test will run, otherwise it won't, and will just return undef.

For test-driven development, it is useful to create failing tests using
I blocks; this prevents test regression. Once the implementation starts
working I can be switched to I.

=cut
sub notest(&$;$) {
    if($UNSTABLE) {
        return _test(0, @_);
    } else {
        my $t = __PACKAGE__->builder();
        $t->skip("$_[-1]");
        return undef;
    }
}

# $dies is a special code ref that we can test for equality. this code doesn't
# actually get run; it's more like a constant.
my $dies = sub {};

# helper function for test, notest and pretest
sub _test {
    my ($pre, $testfunc, $cmpfunc, $name) = @_;
    if(scalar(@_) == 3) {
        $name = $_[-1];
        $cmpfunc = noop();
    } elsif(ref($cmpfunc) ne 'CODE') {
        $cmpfunc = eqv($cmpfunc);
    }

    my $result = eval { &$testfunc() };
    $name = @STACK ? join(".", @STACK) . ".$name" : $name;

    my $t = __PACKAGE__->builder();
    $t->level(3);
    return _ok($@, $name, "    failed to die") if $cmpfunc eq $dies;
    my $ok;
    if($@) {
        _fail($name, "    died: $@") if $@;
        $ok = 0;
    } else {
        $t->level(4);
        $ok = &$cmpfunc($result, $name);
    }
    die if $pre && !$ok && @STACK;
    $t->BAIL_OUT("pretest failed") if !$ok && $pre;
    $t->BAIL_OUT("fastout is on") if !$ok && $FASTOUT;
    return $result;
}

# helper function; wraps calls to builder->ok, displays failure messages, and
# helps keep our builder->level consistent.
sub _ok {
    my ($ok, $name, $failmsg) = @_;
    my $t = __PACKAGE__->builder;
    $t->ok($ok, $name);
    $t->diag($failmsg) if !$ok && $failmsg;
    return $ok;
}

# similar to _ok, but deals with known failure.
sub _fail {
    my ($name, $failmsg) = @_;
    my $t = __PACKAGE__->builder;
    $t->ok(0, $name);
    $t->diag($failmsg) if $failmsg;
    return 0;
}

=item B

Groups are blocks which wrap associated tests. Groups can be used to namespace
tests as well as to allow groups of tests to fail together. Here is a short
example:

    group {
        my $a = coretest { Adder->new } typeqv 'Adder', "new";

        test { $a->add(4, 6) } 10, "4 + 6";
        test { $a->add("cat", "dog") } dies, "mass hysteria";
        test { $a->add() } isundef, "not a number";

    } "adder";

If C<< Adder->new >> fails, the rest of the tests aren't producing useful
results, so they will be skipped. See the L section for a more in-depth
discussion of the package in general, and the implications of test
short-circuiting in particular.

=cut
sub group(&$) {
    my ($func, $name) = @_;

    push(@STACK, $name);
    eval { &$func() };
    pop(@STACK);

    die if $@ && @STACK;
}

=back

=head1 TEST CONDITIONS

=over

=item B

Creates a function which tests that the result is exactly equivalent (eqv) to
I (using Test::More::is_deeply). It works for both simple values and
nested data structures. See L for more details.

If I receives a condition which isn't a code-ref, it will be wrapped in an
I call, since this is the most common case (testing that a result is the
expected value).

=cut
sub eqv($) {
    my ($other) = @_;
    return sub {
        my ($got, $name) = @_;
        return is_deeply($got, $other, $name);
    };
}

=item B

Tests whether the result differs from (is inequivalent to) I according
to Data::Compare. This is expected (hoped?) to be inverse of I.

=cut
sub ineqv($) {
    my ($other) = @_;
    return sub {
        my ($got, $name) = @_;
        return _ok(!Compare($got, $other), $name, "    objects were the same");
    };
}

=item B

Creates a function which tests that the result is of (or inhereits from) the
provided I (that the result's type is equivalent to I). For
unblessed references, it checks that
C. For blessed references it checks that
C<< $result->isa($type) >>. Results which are not references will always be
false.

=cut
sub typeqv($) {
    my($type) = @_;
    return sub {
        my ($got, $name) = @_;
        return _fail($name, "    result was undef") unless defined($got);
        return _fail($name, "    result was not a ref") unless ref($got);
        my $ok = ref($got) eq $type || blessed($got) && $got->isa($type);
        return _ok($ok, $name, "    result was not of type $type");
    };
}

=item B

Verifies that the test's code block died. It is unique amongst test conditions
in that it doesn't test the result, but rather tests C<$@>. Any result other
than a die succeeds.

=cut
sub dies() {
    return $dies;
};

=item B

This is the "default" condition; if no condition is given to a test then this
condition is used. As long as the code block does not die, the test passes.

=cut
sub noop()  {
    return sub {
        my ($got, $name) = @_;
        return _ok(1, $name);
    };
}

=item B

Verifies that the result is a true value.

=cut
sub true()  {
    return sub {
        my ($got, $name) = @_;
        return _ok($got, $name);
    };
}

=item B

Verifies that the result is a false value.

=cut
sub false() {
    return sub {
        my ($got, $name) = @_;
        return _ok(!$got, $name);
    };
}

=item B

Checks that the result is defined (not undef).

=cut
sub isdef() {
    return sub {
        my ($got, $name) = @_;
        return _ok(defined($got), $name);
    };
}

=item B

Checks that the result is undefined.

=cut
sub isundef() {
    return sub {
        my ($got, $name) = @_;
        return _ok(!defined($got), $name);
    };
}

=back

=head1 CUSTOM TEST CONDITIONS

Anonymous subroutines can be used in place of the provided test conditions.
These functions take two arguments: the test result and the test's name. Here
are some examples:

  use Test::More;

  sub over21 {
      my ($result, $name) = @_;
      return cmp_ok($result, '>=', 21, $name);
  }
  test { $alice->age } \&over21, 'can alice drink?';
  test { $bob->age } \&over21, 'can bob drink?';

These examples are kind of clunky, but you get the idea. Using anything
complicated will probably require reading the source, and/or learning how to
use L. In particular, it's important to make sure
C<< builder->level >> is set correctly.

=head1 ETHOS

This package exists to address some specific concerns I've had while writing
tests using other frameworks. As such, it has some pretty major differences from
the other testing frameworks out there.

Most Perl tests are written as perl scripts which test Perl code by calling
functions or methods, and then using various Test packages to look at the
result. This approach has some problems:

=over

=item 1

Test scripts can make bad assumptions or have bugs, causing problems that
aren't obviously linked to a particular test clause and which can be hard to
track down and fix.

=item 2

Writing defensive test scripts involves a bunch of relatively boiler-plate
eval-blocks and C<$@> tests, as well as effectively doubling the number of tests
that are "run" without meaningfully doubling the test coverage.

=item 3

In some cases a small early error causes tons of test clauses to spew useless
messages about failing; this loses sight of the basic issue that caused the
problem (syntax error, missing module, etc).

=back

Test::Functional addresses these concerns: it enables the programmer to write
all the "meat" of the test script inside anonymous subs which are tests [1].
Since each test checks both that the code did not die and that the result was
what was expected, the tester doesn't have to worry about what kind of failure
might occur, just about the expected outcome [2]. Especially when trying to test
other people's code (gray box testing?) this feature is invaluable.

The various features to prematurely end the test (using I and/or
C<< $Test::Functional::Conf->fastout >>) can help the developer to focus on the
problem at hand, rather than having to filter through spew [3]. This is
especially nice during test-driven development, or when trying to increase
coverage for an old and crufty module.

=head1 AUTHOR

Erik Osheim C<<  >>

=head1 BUGS

The syntax takes some getting used to.

I should create default wrappers for things such as I and I from
L. Currently I mostly use I but that gives less debugging
information.

I wrote these tests to suit my needs, so I am sure there are cases I haven't
thought of or encountered. Also, I'm sure I have a lot to learn about the
intricacies of L and L. Please contact me (via
email or L) with any comments, advice, or problems.

=head1 ACKNOWLEDGEMENTS

This module is based on Test::Builder::Module, and relies heavily on the work
done by Michael Schwern. It also uses Data::Compare by David Cantrell.

=head1 COPYRIGHT & LICENSE

Copyright 2009 Erik Osheim, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;