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


line stmt bran cond sub pod time code
1             package Test::Functional;
2              
3 3     3   87647 use warnings FATAL => 'all';
  3         10  
  3         152  
4 3     3   18 use strict;
  3         6  
  3         200  
5              
6             our $VERSION = '0.06';
7              
8             =head1 NAME
9              
10             Test::Functional - Perl tests in a functional style.
11              
12             =head1 SYNOPSIS
13              
14             use Test::Functional;
15              
16             # make sure the bomb goes off
17             sub explode { die "BOOM" }
18             test { explode() } dies, "test-3";
19              
20             # implicit and explicit equivalence
21             test { 2 * 2 } 4, "test-1";
22             test { 2 * 2 } eqv 4, "test-1";
23              
24             # test blocks can be as simple or as involved as you want
25             test { 3 > 0 } true, "test-4";
26             test {
27             my $total = 0;
28             foreach my $person ($car->occupants) {
29             $total += $person->weight
30             }
31             $total < 600
32             } true, "test-5";
33              
34             # after the test runs, you also get the result.
35             my $horse = test { Horse->new } typeqv "Horse", "test-6";
36              
37             # you can make your own comparator functions, or use existing ones.
38             use Test::More import => [qw(like)];
39             sub islike {
40             my ($other) = @_;
41             return sub {
42             my ($got, $testname) = @_;
43             like($got, $other, $testname);
44             };
45             }
46             test { 'caterpillar' } islike(qr/cat/), 'is cat?';
47              
48             =head1 DESCRIPTION
49              
50             This modules uses (abuses?) the ability to create new syntax via perl
51             prototypes to create a testing system focused on functions rather than values.
52             Tests run blocks of Perl, and use comparator functions to test the output.
53             Despite being a different way of thinking about tests, it plays well with
54             L and friends.
55              
56             =cut
57 3     3   2745 use Data::Compare qw(Compare);
  3         59271  
  3         29  
58 3     3   12811 use Scalar::Quote qw(quote);
  3         5494  
  3         264  
59 3     3   148 use Scalar::Util qw(blessed looks_like_number reftype);
  3         5  
  3         218  
60 3     3   1222 use Test::More import => ['is_deeply'];
  3         33210  
  3         42  
61 3     3   3229 use Test::Functional::Conf;
  3         9  
  3         20  
62              
63 3     3   20 use base 'Test::Builder::Module';
  3         12  
  3         6024  
64              
65             =head1 EXPORTS
66              
67             Since this module is going to be used for test scripts, its methods all export
68             by default. You can choose which you want using the standard directives:
69              
70             # import only eqv
71             use Test::Functional tests => 23, import => ['eqv'];
72              
73             # import all but notest
74             use Test::Functional tests => 23, import => ['!notest'];
75              
76             =cut
77             our @EXPORT = (
78             qw(test pretest notest group),
79             qw(eqv ineqv typeqv dies noop true false isdef isundef),
80             );
81              
82             # three global variables: two settings and a stack for test groups
83             my ($UNSTABLE, $FASTOUT, @STACK);
84              
85             =head1 CONFIGURE
86              
87             This package has two settings which can be altered to change performance:
88              
89             unstable - run tests which are normally skipped
90             fastout - cause the entire test to end after the first failure
91              
92             This package can be configured via L or the configure()
93             function.
94              
95             =over
96              
97             =item configure KEY => VALUE, ...
98              
99             Changes configuration values at run-time.
100              
101             =cut
102             sub configure {
103 3     3 1 11 my (%opts) = @_;
104 3 50       22 $UNSTABLE = $opts{unstable} if exists($opts{unstable});
105 3 50       22 $FASTOUT = $opts{fastout} if exists($opts{fastout});
106             }
107              
108             configure(
109             unstable => Test::Functional::Conf->unstable,
110             fastout => Test::Functional::Conf->fastout,
111             );
112              
113             =back
114              
115             =head1 TEST STRUCTURES
116              
117             =over
118              
119             =item B
120              
121             This is the basic building block of Test::Functional. Each test function
122             contains an anonymous code block (which is expected to return a scalar
123             I), a name for the test, and a condition (an optional subroutine to
124             check the result).
125              
126             In most cases, a test passes if the code block doesn't die, and if the condition
127             is true (or absent). There is a special condition I which expects the code
128             block to die, and fails unless it does so.
129              
130             Whether the test passes or fails, I returns the value generated by
131             I.
132              
133             =cut
134             sub test(&$;$) {
135 378     378 1 791 return _test(0, @_);
136             }
137              
138             =item B
139              
140             This works like I except that if it fails, it will short-circuit all
141             testing at the current level. This means that top-level I calls will
142             halt the entire test if they fail. One obvious example for this is:
143              
144             BEGIN { pretest { use Foo::Bar } "test-use" }
145             test { Foo::Bar::double(2) } eqv(4), "double(2)";
146             test { Foo::Bar::double(3) } eqv(6), "double(3)";
147             test { Foo::Bar::double(4) } eqv(8), "double(4)";
148              
149             If the C fails, the information that all the other tests are
150             failing is less useful. I can also be combined with I
151             (described later) to short-circuit a small set of related tests.
152              
153             =cut
154             sub pretest(&$;$) {
155 0     0 1 0 return _test(1, @_);
156             }
157              
158             =item B
159              
160             This is has exactly the same semantics as I; the only difference is that
161             it normally doesn't run. If C<< Test::Functional::Conf->unstable >> is true,
162             then this test will run, otherwise it won't, and will just return undef.
163              
164             For test-driven development, it is useful to create failing tests using
165             I blocks; this prevents test regression. Once the implementation starts
166             working I can be switched to I.
167              
168             =cut
169             sub notest(&$;$) {
170 0 0   0 1 0 if($UNSTABLE) {
171 0         0 return _test(0, @_);
172             } else {
173 0         0 my $t = __PACKAGE__->builder();
174 0         0 $t->skip("$_[-1]");
175 0         0 return undef;
176             }
177             }
178              
179             # $dies is a special code ref that we can test for equality. this code doesn't
180             # actually get run; it's more like a constant.
181             my $dies = sub {};
182              
183             # helper function for test, notest and pretest
184             sub _test {
185 378     378   582 my ($pre, $testfunc, $cmpfunc, $name) = @_;
186 378 100       1345 if(scalar(@_) == 3) {
    100          
187 1         2 $name = $_[-1];
188 1         4 $cmpfunc = noop();
189             } elsif(ref($cmpfunc) ne 'CODE') {
190 17         37 $cmpfunc = eqv($cmpfunc);
191             }
192              
193 378         476 my $result = eval { &$testfunc() };
  378         1414  
194 378 50       3039 $name = @STACK ? join(".", @STACK) . ".$name" : $name;
195              
196 378         1352 my $t = __PACKAGE__->builder();
197 378         3977 $t->level(3);
198 378 100       2975 return _ok($@, $name, " failed to die") if $cmpfunc eq $dies;
199 373         567 my $ok;
200 373 50       994 if($@) {
201 0 0       0 _fail($name, " died: $@") if $@;
202 0         0 $ok = 0;
203             } else {
204 373         1005 $t->level(4);
205 373         2005 $ok = &$cmpfunc($result, $name);
206             }
207 373 0 33     26655 die if $pre && !$ok && @STACK;
      33        
208 373 50 33     851 $t->BAIL_OUT("pretest failed") if !$ok && $pre;
209 373 50 33     827 $t->BAIL_OUT("fastout is on") if !$ok && $FASTOUT;
210 373         3311 return $result;
211             }
212              
213             # helper function; wraps calls to builder->ok, displays failure messages, and
214             # helps keep our builder->level consistent.
215             sub _ok {
216 342     342   15206 my ($ok, $name, $failmsg) = @_;
217 342         1428 my $t = __PACKAGE__->builder;
218 342         3207 $t->ok($ok, $name);
219 342 50 33     162940 $t->diag($failmsg) if !$ok && $failmsg;
220 342         1286 return $ok;
221             }
222              
223             # similar to _ok, but deals with known failure.
224             sub _fail {
225 0     0   0 my ($name, $failmsg) = @_;
226 0         0 my $t = __PACKAGE__->builder;
227 0         0 $t->ok(0, $name);
228 0 0       0 $t->diag($failmsg) if $failmsg;
229 0         0 return 0;
230             }
231              
232             =item B
233              
234             Groups are blocks which wrap associated tests. Groups can be used to namespace
235             tests as well as to allow groups of tests to fail together. Here is a short
236             example:
237              
238             group {
239             my $a = coretest { Adder->new } typeqv 'Adder', "new";
240              
241             test { $a->add(4, 6) } 10, "4 + 6";
242             test { $a->add("cat", "dog") } dies, "mass hysteria";
243             test { $a->add() } isundef, "not a number";
244              
245             } "adder";
246              
247             If C<< Adder->new >> fails, the rest of the tests aren't producing useful
248             results, so they will be skipped. See the L section for a more in-depth
249             discussion of the package in general, and the implications of test
250             short-circuiting in particular.
251              
252             =cut
253             sub group(&$) {
254 0     0 1 0 my ($func, $name) = @_;
255              
256 0         0 push(@STACK, $name);
257 0         0 eval { &$func() };
  0         0  
258 0         0 pop(@STACK);
259              
260 0 0 0     0 die if $@ && @STACK;
261             }
262              
263             =back
264              
265             =head1 TEST CONDITIONS
266              
267             =over
268              
269             =item B
270              
271             Creates a function which tests that the result is exactly equivalent (eqv) to
272             I (using Test::More::is_deeply). It works for both simple values and
273             nested data structures. See L for more details.
274              
275             If I receives a condition which isn't a code-ref, it will be wrapped in an
276             I call, since this is the most common case (testing that a result is the
277             expected value).
278              
279             =cut
280             sub eqv($) {
281 35     35 1 188 my ($other) = @_;
282             return sub {
283 35     35   56 my ($got, $name) = @_;
284 35         142 return is_deeply($got, $other, $name);
285 35         177 };
286             }
287              
288             =item B
289              
290             Tests whether the result differs from (is inequivalent to) I according
291             to Data::Compare. This is expected (hoped?) to be inverse of I.
292              
293             =cut
294             sub ineqv($) {
295 306     306 1 2918 my ($other) = @_;
296             return sub {
297 306     306   420 my ($got, $name) = @_;
298 306         844 return _ok(!Compare($got, $other), $name, " objects were the same");
299 306         2224 };
300             }
301              
302             =item B
303              
304             Creates a function which tests that the result is of (or inhereits from) the
305             provided I (that the result's type is equivalent to I). For
306             unblessed references, it checks that
307             C. For blessed references it checks that
308             C<< $result->isa($type) >>. Results which are not references will always be
309             false.
310              
311             =cut
312             sub typeqv($) {
313 18     18 1 177 my($type) = @_;
314             return sub {
315 18     18   27 my ($got, $name) = @_;
316 18 50       37 return _fail($name, " result was undef") unless defined($got);
317 18 50       92 return _fail($name, " result was not a ref") unless ref($got);
318 18   66     127 my $ok = ref($got) eq $type || blessed($got) && $got->isa($type);
319 18         67 return _ok($ok, $name, " result was not of type $type");
320 18         136 };
321             }
322              
323             =item B
324              
325             Verifies that the test's code block died. It is unique amongst test conditions
326             in that it doesn't test the result, but rather tests C<$@>. Any result other
327             than a die succeeds.
328              
329             =cut
330             sub dies() {
331 5     5 1 26 return $dies;
332             };
333              
334             =item B
335              
336             This is the "default" condition; if no condition is given to a test then this
337             condition is used. As long as the code block does not die, the test passes.
338              
339             =cut
340             sub noop() {
341             return sub {
342 2     2   3 my ($got, $name) = @_;
343 2         7 return _ok(1, $name);
344 2     2 1 18 };
345             }
346              
347             =item B
348              
349             Verifies that the result is a true value.
350              
351             =cut
352             sub true() {
353             return sub {
354 3     3   5 my ($got, $name) = @_;
355 3         6 return _ok($got, $name);
356 3     3 1 17 };
357             }
358              
359             =item B
360              
361             Verifies that the result is a false value.
362              
363             =cut
364             sub false() {
365             return sub {
366 3     3   6 my ($got, $name) = @_;
367 3         8 return _ok(!$got, $name);
368 3     3 1 18 };
369             }
370              
371             =item B
372              
373             Checks that the result is defined (not undef).
374              
375             =cut
376             sub isdef() {
377             return sub {
378 4     4   6 my ($got, $name) = @_;
379 4         11 return _ok(defined($got), $name);
380 4     4 1 20 };
381             }
382              
383             =item B
384              
385             Checks that the result is undefined.
386              
387             =cut
388             sub isundef() {
389             return sub {
390 1     1   3 my ($got, $name) = @_;
391 1         4 return _ok(!defined($got), $name);
392 1     1 1 7 };
393             }
394              
395             =back
396              
397             =head1 CUSTOM TEST CONDITIONS
398              
399             Anonymous subroutines can be used in place of the provided test conditions.
400             These functions take two arguments: the test result and the test's name. Here
401             are some examples:
402              
403             use Test::More;
404              
405             sub over21 {
406             my ($result, $name) = @_;
407             return cmp_ok($result, '>=', 21, $name);
408             }
409             test { $alice->age } \&over21, 'can alice drink?';
410             test { $bob->age } \&over21, 'can bob drink?';
411              
412             These examples are kind of clunky, but you get the idea. Using anything
413             complicated will probably require reading the source, and/or learning how to
414             use L. In particular, it's important to make sure
415             C<< builder->level >> is set correctly.
416              
417             =head1 ETHOS
418              
419             This package exists to address some specific concerns I've had while writing
420             tests using other frameworks. As such, it has some pretty major differences from
421             the other testing frameworks out there.
422              
423             Most Perl tests are written as perl scripts which test Perl code by calling
424             functions or methods, and then using various Test packages to look at the
425             result. This approach has some problems:
426              
427             =over
428              
429             =item 1
430              
431             Test scripts can make bad assumptions or have bugs, causing problems that
432             aren't obviously linked to a particular test clause and which can be hard to
433             track down and fix.
434              
435             =item 2
436              
437             Writing defensive test scripts involves a bunch of relatively boiler-plate
438             eval-blocks and C<$@> tests, as well as effectively doubling the number of tests
439             that are "run" without meaningfully doubling the test coverage.
440              
441             =item 3
442              
443             In some cases a small early error causes tons of test clauses to spew useless
444             messages about failing; this loses sight of the basic issue that caused the
445             problem (syntax error, missing module, etc).
446              
447             =back
448              
449             Test::Functional addresses these concerns: it enables the programmer to write
450             all the "meat" of the test script inside anonymous subs which are tests [1].
451             Since each test checks both that the code did not die and that the result was
452             what was expected, the tester doesn't have to worry about what kind of failure
453             might occur, just about the expected outcome [2]. Especially when trying to test
454             other people's code (gray box testing?) this feature is invaluable.
455              
456             The various features to prematurely end the test (using I and/or
457             C<< $Test::Functional::Conf->fastout >>) can help the developer to focus on the
458             problem at hand, rather than having to filter through spew [3]. This is
459             especially nice during test-driven development, or when trying to increase
460             coverage for an old and crufty module.
461              
462             =head1 AUTHOR
463              
464             Erik Osheim C<< >>
465              
466             =head1 BUGS
467              
468             The syntax takes some getting used to.
469              
470             I should create default wrappers for things such as I and I from
471             L. Currently I mostly use I but that gives less debugging
472             information.
473              
474             I wrote these tests to suit my needs, so I am sure there are cases I haven't
475             thought of or encountered. Also, I'm sure I have a lot to learn about the
476             intricacies of L and L. Please contact me (via
477             email or L) with any comments, advice, or problems.
478              
479             =head1 ACKNOWLEDGEMENTS
480              
481             This module is based on Test::Builder::Module, and relies heavily on the work
482             done by Michael Schwern. It also uses Data::Compare by David Cantrell.
483              
484             =head1 COPYRIGHT & LICENSE
485              
486             Copyright 2009 Erik Osheim, all rights reserved.
487              
488             This program is free software; you can redistribute it and/or modify it
489             under the same terms as Perl itself.
490              
491             =cut
492              
493             1;