File Coverage

blib/lib/Test/Group.pm
Criterion Covered Total %
statement 212 269 78.8
branch 73 120 60.8
condition 20 29 68.9
subroutine 51 63 80.9
pod 13 13 100.0
total 369 494 74.7


line stmt bran cond sub pod time code
1             #!/usr/bin/perl -w
2             # -*- coding: utf-8; -*-
3             #
4             # (C)-IDEALX
5              
6             package Test::Group;
7 12     12   154501 use strict;
  12         19  
  12         443  
8 12     12   48 use warnings;
  12         16  
  12         357  
9              
10             =head1 NAME
11              
12             Test::Group - Group together related tests in a test suite
13              
14             =head1 VERSION
15              
16             Test::Group version 0.20
17              
18             =cut
19              
20 12     12   44 use vars qw($VERSION);
  12         19  
  12         1108  
21             $VERSION = '0.20';
22              
23             =head1 SYNOPSIS
24              
25             Basics:
26              
27             =for tests "synopsis-success" begin
28              
29             use Test::More no_plan => 1;
30             use Test::Group;
31              
32             test "hammering the server" => sub {
33             ok(I_can_connect);
34             for(1..1000) {
35             ok(I_can_make_a_request);
36             }
37             }; # Don't forget the semicolon here!
38              
39             =for tests "synopsis-success" end
40              
41             Failed subtests are displayed I the result of the test they belong to.
42             For instance,
43              
44             =for tests "synopsis-fail" begin
45              
46             use Test::More no_plan => 1;
47             use Test::Group;
48              
49             test "this test group will fail", sub {
50             ok 1, "sub test blah";
51             is "foo", "bar", "I so wish they were the same...";
52             ok 1;
53             like "blah blah blah", qr/bla/;
54             };
55              
56             =for tests "synopsis-fail" end
57              
58             produces something like this:
59              
60             # Failed test 'I so wish they were the same...'
61             # in test.pl at line 6.
62             # got: 'foo'
63             # expected: 'bar'
64             not ok 1 - this test group will fail
65             # Failed test 'this test group will fail'
66             # in test.pl at line 9.
67             1..1
68              
69             Exceptions in tests are not fatal:
70              
71             =for tests "synopsis-die" begin
72              
73             test "this test will fail but the suite will proceed", sub {
74             pass;
75             die;
76             };
77              
78              
79             =for tests "synopsis-die" end
80              
81             Test::More style TODO support:
82              
83             =for tests "synopsis-TODO" begin
84              
85             test "a test with TODO in the name is marked TODO" => sub {
86             pass("this part is done");
87             fail("but I'm not finished with this one yet");
88             };
89              
90             {
91             local $TODO = "Test::More's good old method also works";
92             test "this test is not finished yet" => sub {
93             pass;
94             fail;
95             };
96             };
97              
98             =for tests "synopsis-TODO" end
99              
100             Misc:
101              
102             =for tests "synopsis-misc" begin
103              
104             # Don't catch exceptions raised in test groups later on
105             Test::Group->dont_catch_exceptions;
106              
107             # log caught exceptions in /tmp/log
108             Test::Group->logfile("/tmp/log");
109              
110             # skip the next group of test
111             skip_next_test "network not available" if (! Network->available());
112             test "bla", sub {
113             my $ftp = Net::FTP->new("some.host.name");
114             # ...
115             };
116              
117             begin_skipping_tests "reason";
118              
119             test "this test will not run" => sub {
120             # ...
121             };
122              
123             end_skipping_tests;
124              
125             # from now on, skip all tests whose names do not match /bla/
126             test_only qr/bla/;
127              
128             =for tests "synopsis-misc" end
129              
130             =head1 DESCRIPTION
131              
132             Fed up with counting tests to discover what went wrong in your last
133             test run? Tired of squinting at your test source to find out where on
134             earth the faulty test predicate is called, and what it is supposed to
135             check for? Then this module is for you!
136              
137             I allows for grouping together related tests in a
138             standard I-style script. (If you are not already familiar
139             with L, now would be the time to go take a look.)
140             I provides a bunch of maintainability and scalability
141             advantages to large test suites:
142              
143             =over
144              
145             =item *
146              
147             related tests can be grouped and given a name. The intent of the test
148             author is therefore made explicit with much less effort than would be
149             needed to name all the individual tests;
150              
151             =item *
152              
153             the test output is much shorter and more readable: only failed
154             subtests show a diagnostic, while test groups with no problems inside
155             produce a single friendly C line;
156              
157             =item *
158              
159             no more tedious test counting: running an arbitrarily large or
160             variable number of tests (e.g. in loops) is now hassle-free and
161             doesn't clutter the test output.
162              
163             =back
164              
165             Authors of I modules may also find I of
166             interest, because it allows for composing several L
167             predicates into a single one (see L).
168              
169              
170             =head1 FEATURES
171              
172             =head2 Blocking Exceptions
173              
174             By default, calls to L and other exceptions from within
175             a test group cause it to fail and terminates execution of the group,
176             but does not terminate whole script. This relieves the programmer
177             from having to worry about code that may throw in tests.
178              
179             This behavior can be disabled totally using L.
180             Exceptions can also be trapped as usual using L or
181             otherwise from inside a group, in which case the test code of course
182             has full control on what to do next (this is how one should test error
183             management, by the way).
184              
185             When Test::Group is set to block errors (the default setting, see also
186             L), the error messages are displayed as part of the
187             test name, which some may not find very readable. Therefore, one can
188             use a L instead.
189              
190             =head2 Skipping Groups
191              
192             I can skip single test groups or a range of them
193             (consecutive or matched by a regex), which helps shortening the debug
194             cycle even more in test-driven programming. When a test group is
195             skipped, the code within it is simply not executed, and the test is
196             marked as skipped wrt L. See L,
197             L, L, L
198             and L for details.
199              
200             =head2 Reflexivity
201              
202             Test groups integrate with L by acting as a single big
203             test; therefore, I is fully reflexive. A particularly
204             attractive consequence is that constructing new L
205             predicates is straightforward with I. For example,
206              
207             =for tests "foobar_ok" begin
208              
209             use Test::Builder;
210             use Test::Group;
211              
212             sub foobar_ok {
213             my ($text, $name) = @_;
214             $name ||= "foobar_ok";
215             local $Test::Builder::Level = $Test::Builder::Level + 1;
216             test $name => sub {
217             local $Test::Group::InPredicate = 1;
218             like($text, qr/foo/, "foo ok");
219             like($text, qr/bar/, "bar ok");
220             };
221             }
222              
223             =for tests "foobar_ok" end
224              
225             defines a new test predicate I that will DWIM regardless of
226             the caller's testing style: for "classical" L or
227             L users, I will act as just another I<*_ok>
228             predicate (in particular, it always counts for a single test, honors
229             L constructs, etc); and of course, users of
230             I can freely call I from within a group.
231              
232             Adding 1 to C<$Test::Builder::Level> causes the location of the call
233             to foobar_ok() to be shown if a test fails, see L.
234              
235             Setting C<$Test::Group::InPredicate> to a true value prevents the
236             location of individual failing tests within test groups from being
237             shown.
238              
239             =head2 TODO Tests
240              
241             As shown in L, L's concept of TODO tests is
242             supported by I: a group is in TODO state if the $TODO
243             variable is set by the time it starts, or if the test name contains
244             the word C. Note, however, that setting $TODO from B
245             the test group (that is, B the group starts) will not do what
246             you mean:
247              
248             =for tests "TODO gotcha" begin
249              
250             test "something" => sub {
251             local $TODO = "this test does not work yet";
252             pass; # GOTCHA!
253             fail;
254             };
255              
256             =for tests "TODO gotcha" end
257              
258             Here C is an unexpected success, and therefore the whole test
259             group will report a TODO success despite the test not actually being a
260             success (that is, it would B be defective if one were to comment
261             out the C line). This semantics, on the other hand,
262             DWIMs for marking a B of the test group as TODO:
263              
264             =for tests "TODO correct" begin
265              
266             test "something" => sub {
267             pass;
268             {
269             local $TODO = "this part does not work yet";
270             fail;
271             }
272             };
273              
274             =for tests "TODO correct" end
275              
276             Finally, there is a subtle gotcha to be aware of when setting $TODO
277             outside a test group (that's the second one, so maybe you should not
278             do that to begin with). In this case, the value of $TODO is set to
279             undef B the group. In other words, this test (similar to the
280             one to be found in L) will succeed as expected:
281              
282             =for tests "TODO gotcha 2" begin
283              
284             {
285             local $TODO = "not quite done yet";
286             test "foo" => sub {
287             fail;
288             pass; # NOT an unexpected success, as
289             # this is simply a subtest of the whole
290             # test "foo", which will fail.
291             };
292             }
293              
294             =for tests "TODO gotcha 2" end
295              
296             =head2 OUTPUT FORMAT
297              
298             As seen briefly in L, only top-level test groups (and toplevel
299             Test::More tests if any) produce a single "ok" or "not ok" summary line. Failed
300             sub-tests produce non-scoring comment messages (prefixed with "#"); successful
301             sub-tests are silent. This is different from, and predates, the
302             L functionality.
303              
304             However, if you enable the experimental L feature then
305             I will use the same underlying mechanism as
306             L and produce very similar output.
307              
308             =head2 PLUGIN INTERFACE
309              
310             A simple plugin interface allows module authors to write extensions
311             to I. See L for details.
312              
313             The following extensions are distributed with I:
314              
315             L, L
316              
317             =cut
318              
319 12     12   214 use 5.004;
  12         33  
  12         307  
320              
321 12     12   4851 use Test::Simple;
  12         2899  
  12         65  
322 12     12   1308 use Test::Builder;
  12         15  
  12         331  
323 12 50   12   233 BEGIN { die "Need Test::Simple version 0.59 or later, sorry"
324             unless Test::Builder->can("create"); }
325 12     12   5171 use IO::File;
  12         75593  
  12         1213  
326 12     12   79 use File::Spec;
  12         16  
  12         955  
327              
328             my $classstate_verbose = $ENV{PERL_TEST_GROUP_VERBOSE};
329             my $classstate_skipcounter;
330             my $classstate_skipreason;
331             my $classstate_testonly_reason;
332             my $classstate_testonly_criteria = sub { 1 };
333             my $classstate_catchexceptions = 1;
334             my $classstate_logfile;
335             my $classstate_logfd;
336             my @classstate_plugins;
337             my $classstate_use_subtest;
338              
339             our $Level = 0;
340             # $Test::Group::Level is effectively added to $Test::Builder::Level.
341             # Do not use it, it is present for backward compatibility only.
342             # Use $Test::Builder::Level instead.
343              
344             our $InPredicate;
345              
346             =head2 FUNCTIONS
347              
348             All functions below are intended to be called from the test
349             script. They are all exported by default.
350              
351             =cut
352              
353 12     12   49 use Exporter;
  12         19  
  12         490  
354 12     12   50 use vars qw(@ISA @EXPORT @EXPORT_OK);
  12         15  
  12         2170  
355             @ISA = qw(Exporter);
356             @EXPORT = qw(test skip_next_test skip_next_tests
357             begin_skipping_tests end_skipping_tests
358             test_only);
359             @EXPORT_OK = qw(next_test_plugin);
360              
361             =head3 test ($name, $groupsub)
362              
363             Executes I<$groupsub>, which must be a reference to a subroutine, in a
364             controlled environment and groups the results of all
365             L-style subtests launched inside into a single call to
366             L, regardless of their number. If the test group is
367             to be skipped (as discussed in L), calls
368             L once instead.
369              
370             In case the test group is B skipped, the first parameter to
371             L and the value of the TODO string during same (see
372             L) are determined according to the following
373             algorithm:
374              
375             =over
376              
377             =item 1
378              
379             if the test group terminates by throwing an exception, or terminates
380             normally but without calling any subtest, it fails.
381              
382             =item 2
383              
384             otherwise, if any subtest failed outside of a TODO block, the group
385             fails.
386              
387             =item 3
388              
389             otherwise, if any subtest B inside of a TODO block, the
390             group is flagged as an unexpected success.
391              
392             =item 4
393              
394             otherwise, if any subtest fails inside of a TODO block, the group
395             results in a TODO (excused) failure.
396              
397             =item 5
398              
399             otherwise, the test group managed to avert all hazards and is a
400             straight success (tada!!).
401              
402             =back
403              
404             If any sub-tests failed in I<$groupsub>, diagnostics will be
405             propagated using L as usual.
406              
407             The return value of I is 1 if the test group is a success
408             (including a TODO unexpected success), 0 if it is a failure (including
409             a TODO excused failure), and undef if the test group was skipped.
410              
411             =cut
412              
413             sub test ($&) {
414 51     51 1 13999 my ($name, $code) = @_;
415              
416 51         345 my ($callerpackage) = caller(0);
417              
418 51         130 my $Test = Test::Builder->new; # This is a singleton actually -
419             # it should read "Test::Builder->the()" with permission from
420             # Michael Schwern :-)
421              
422 51         272 my $subTest = Test::Group::_Runner->new($name, $callerpackage, $code);
423 51         106 $subTest->run();
424              
425 51 100       84 if ($subTest->is_skipped) {
426 3         7 $Test->skip($subTest->skip_reason);
427 3         26 return;
428             }
429              
430 48 100       69 if ($subTest->got_exception) {
431 1         2 my $exn = $subTest->exception();
432             my $exntext =
433             ( ! defined $exn ? "an undefined exception" :
434 1         18 eval { $exn->can("stringify") } ? $exn->stringify :
435 1 50 33     3 (ref($exn) && $Data::Dumper::VERSION ) ? do {
    50          
    50          
    50          
436 12     12   45 no warnings "once";
  12         12  
  12         1750  
437 0         0 local $Data::Dumper::Indent = 1;
438 0         0 local $Data::Dumper::Terse = 1;
439 0         0 Data::Dumper::Dumper($exn) } :
440             "$exn" ? "$exn" : "a blank exception" );
441 1         1 { local $/ = ""; chomp($exntext); }
  1         4  
  1         3  
442 1         3 my $message = <<"MESSAGE";
443             Test ``$name'' died:
444             $exntext
445             MESSAGE
446 1 50       2 if ($classstate_logfd) {
447 0         0 print $classstate_logfd $message;
448 0         0 $Test->diag("test ``$name'' died - "
449             . "see log file: ``$classstate_logfile''");
450             } else {
451 1         1 $Test->diag($message);
452             };
453 1         2 $name = "*died* $name";
454             }
455              
456 48 100       162 return $subTest->{result} if exists $subTest->{result};
457              
458 12     12   44 no warnings "redefine";
  12         12  
  12         20111  
459 13         24 my ($OK, $TODO_string) = $subTest->as_Test_Builder_params;
460             # I tried to put a "local $TODO = " here, but that didn't work and
461             # I lack the patience to dig up the whole story about
462             # Test::Builder->caller not doing The Right Thing here (yet
463             # elsewhere it does when it apparently shouldn't, e.g. in
464             # L). So here goes a sleazy local-method trick to get the
465             # TODO status across to Test::Builder; the trick has an adherence
466             # in L, which see.
467 13     13   56 local *Test::Builder::todo = sub { $TODO_string };
  13         131  
468 13     4   34 local *Test::Builder::in_todo = sub { defined($TODO_string) };
  4         70  
469 13         18 local $Test::Builder::Level = $Test::Builder::Level + $Level;
470 13         28 $Test->ok($OK, $name);
471 13 100       261 return $OK ? 1 : 0;
472             }
473              
474             =head3 skip_next_tests ($number)
475              
476             =head3 skip_next_tests ($number, $reason)
477              
478             Skips the $number following groups of tests with reason $reason. Dies
479             if we are currently skipping tests already.
480              
481             =head3 skip_next_test ()
482              
483             =head3 skip_next_test ($reason)
484              
485             Equivalent to:
486              
487             skip_next_tests 1;
488             skip_next_tests 1, $reason;
489              
490             =head3 begin_skipping_tests ()
491              
492             begin_skipping_tests;
493             begin_skipping_tests "reason";
494              
495             Skips all subsequent groups of tests until blocked by
496             L.
497              
498             =head3 end_skipping_tests ()
499              
500             Cancels the effect of L. Has no effect if we
501             are not currently skipping tests.
502              
503             =cut
504              
505             sub skip_next_tests {
506 2     2 1 4 my ($counter, $reason) = @_;
507 2 50 33     7 $classstate_skipcounter = $counter unless
508             ($classstate_skipcounter && $classstate_skipcounter > $counter);
509 2         3 $classstate_skipreason = $reason;
510 2         35 return 1;
511             }
512              
513             sub skip_next_test {
514 2     2 1 308 skip_next_tests 1, @_;
515             }
516              
517             sub begin_skipping_tests {
518 2     2 1 25 my ($reason) = @_;
519 2         5 $classstate_skipcounter = -1;
520 2         3 $classstate_skipreason = $reason;
521 2         10 return 1;
522             }
523              
524             sub end_skipping_tests {
525 2     2 1 20 $classstate_skipcounter = 0;
526 2         9 return 1;
527             }
528              
529             =head3 test_only ()
530              
531             test_only "bla()", "reason";
532             test_only qr/^bla/;
533             test_only sub { /bla/ };
534              
535             Skip all groups of tests whose name does not match the criteria. The
536             criteria can be a plain string, a regular expression or a function.
537              
538             test_only;
539              
540             Resets to normal behavior.
541              
542             =cut
543              
544             sub test_only (;$$) {
545 1     1 1 8 my ($criteria, $reason) = @_;
546              
547 1         1 $classstate_testonly_reason = $reason;
548              
549 1 50       6 if (!defined $criteria) {
    50          
    50          
    0          
550 0     0   0 $classstate_testonly_criteria = sub { 1 };
  0         0  
551             } elsif (!ref $criteria) {
552 0     0   0 $classstate_testonly_criteria = sub { $_[0] eq $criteria };
  0         0  
553             } elsif (ref $criteria eq "Regexp") {
554 1     0   12 $classstate_testonly_criteria = sub { $_[0] =~ /$criteria/ };
  0         0  
555             } elsif (ref $criteria eq "CODE") {
556 0         0 $classstate_testonly_criteria = $criteria;
557             }
558             }
559              
560             =head2 PLUGIN FUNCTIONS
561              
562             The following function relates to the plugin interface. It is not
563             exported by default. See L for details.
564              
565             =head3 next_test_plugin ($plugin)
566              
567             Installs a plugin for the next test group. I<$plugin> must be a
568             subroutine reference.
569              
570             =cut
571              
572             sub next_test_plugin (&) {
573 0     0 1 0 my $plugin = shift;
574              
575 0         0 push @classstate_plugins, $plugin;
576             }
577              
578             =head1 CLASS METHODS
579              
580             A handful of class methods are available to tweak the behavior of this
581             module on a global basis. They are to be invoked like this:
582              
583             Test::Group->foo(@args);
584              
585             =head2 verbose ($level)
586              
587             Sets verbosity level to $level, where 0 means quietest.
588              
589             At level 1 and above there is a diagnostic line for the start of each
590             test group.
591              
592             At level 2 there is a diagnostic line showing the result of each
593             subtest within top-level test groups. At level 3, the subtests of test
594             groups nested within top level test groups also get diagnostic lines,
595             and so on.
596              
597             The default verbosity level is 0, or the value of the
598             C environment variable if it is set.
599              
600             =cut
601              
602 0     0 1 0 sub verbose { shift; $classstate_verbose = shift }
  0         0  
603              
604             =head2 catch_exceptions ()
605              
606             Causes exceptions thrown from within the sub reference passed to
607             L to be blocked; in this case, the test currently running will
608             fail but the suite will proceed. This is the default behavior.
609              
610             Note that I only deals with exceptions arising
611             inside I blocks; those thrown by surrounding code (if any) still
612             cause the test script to terminate as usual unless other appropriate
613             steps are taken.
614              
615             =head2 dont_catch_exceptions ()
616              
617             Reverses the effect of L, and causes exceptions
618             thrown from a L sub reference to be fatal to the whole suite.
619             This only takes effect for test subs that run after
620             I returns; in other words this is B a
621             whole-script pragma.
622              
623             =cut
624              
625 0     0 1 0 sub catch_exceptions { $classstate_catchexceptions = 1; }
626 1     1 1 22 sub dont_catch_exceptions { $classstate_catchexceptions = 0; }
627              
628             =head2 logfile ($classstate_logfile)
629              
630             Sets the log file for caught exceptions to F<$classstate_logfile>.
631             From this point on, all exceptions thrown from within a text group
632             (assuming they are caught, see L) will be written
633             to F<$classstate_logfile> instead of being passed on to
634             L. This is very convenient with exceptions with a
635             huge text representation (say an instance of L containing a
636             stack trace).
637              
638             =cut
639              
640             sub logfile {
641 1     1 1 4 my $class = shift;
642 1         1 $classstate_logfile = shift;
643 1 50       7 $classstate_logfd = new IO::File("> $classstate_logfile") or
644             die "Cannot open $classstate_logfile";
645             }
646              
647             =head2 use_subtest ()
648              
649             This feature is experimental.
650              
651             Causes I to use L's subtest() feature as
652             the test aggregation method, rather than doing black magic behind the
653             scenes.
654              
655             It is a fatal error to call use_subtest() if L is too
656             old to support subtests. To use subtests if they are available but
657             fall back to normal operation if they are not, you can do:
658              
659             eval { Test::Group->use_subtest };
660              
661             I's exception handling mechanism is bypassed under
662             use_subtest(), since Test::Builder::subtest() has its own exception
663             handling system.
664              
665             =cut
666              
667             sub use_subtest {
668 2 50   2 1 38 Test::Builder->new->can('subtest') or die
669             "Test::Builder too old for use_subtest()\n";
670 2         29 $classstate_use_subtest = 1;
671             }
672            
673             =head2 no_subtest ()
674              
675             Turns off use_subtest.
676              
677             =cut
678              
679             sub no_subtest {
680 0     0 1 0 $classstate_use_subtest = 0;
681             }
682              
683             =begin internals
684              
685             =head1 INTERNALS
686              
687             =head2 Test::Group::_Runner internal class
688              
689             This is an internal class whose job is to observe the tests in lieu of
690             the real I singleton (see L) during
691             the time the I<$groupsub> argument to L is being run.
692             Short-circuiting L involves a fair amount of black
693             magic, which is performed using the
694             L as an
695             accomplice.
696              
697             =cut
698              
699             package Test::Group::_Runner;
700              
701             =head3 new ($name, $callerpackage, $sub)
702              
703             Object constructor; constructs an object that models only the state of
704             the test group $sub that is about to be run as if L had been
705             invoked from $callerpackage. This I object is
706             available by calling L from $sub, while it is being executed
707             by L. Afterwards, it can be queried using L and
708             other methods to discover how the test group run went.
709              
710             =cut
711              
712             sub new {
713 83     83   133800 my ($class, $name, $callerpackage, $code) = @_;
714              
715 83         322 my $self = bless {
716             name => $name,
717             callerpackage => $callerpackage,
718             code => $code,
719             subtests => [],
720             }, $class;
721             # Stash the TODO state on behalf of L,
722             # coz we're going to muck with $TODO soon. Warning, ->todo
723             # returns 0 instead of undef if there is no TODO block active:
724 83         172 my $T = Test::Builder->new;
725 83         369 my $current_todo = $T->todo($callerpackage);
726 83 100       943 $self->{in_todo} = $current_todo if $current_todo;
727              
728             # For testability: test groups run inside a mute group are mute as
729             # well.
730 83 100 100     142 $self->mute(1) if ($class->current &&
731             $class->current->mute);
732              
733 83         130 return $self;
734             }
735              
736             =head3 run ()
737              
738             Executes the $sub test group passed as the second parameter to
739             L, monitoring the results of the sub-tests and stashing them
740             into L. Invoking C<< ->new($name, $sub) >> then C<<
741             ->run() >> is the same as running with the same parameters,
742             except that I additionally passes along the test group results
743             to L.
744              
745             If any plugins have been set, they are applied to the test group and
746             the list of plugins is cleared.
747              
748             =cut
749              
750             sub run {
751 83     83   193 my ($self) = @_;
752              
753 83 100       237 if ($classstate_skipcounter) {
    50          
754 6         9 $classstate_skipcounter--;
755 6         20 $self->_skip($classstate_skipreason);
756 6 100       15 undef $classstate_skipreason unless $classstate_skipcounter;
757 6         10 return $self;
758             } elsif (! $classstate_testonly_criteria->($self->{name})) {
759 0         0 $self->_skip($classstate_testonly_reason);
760 0         0 return $self;
761             }
762              
763 77 50       118 Test::Builder->new->diag("Running group of tests - $self->{name}")
764             if ($classstate_verbose);
765              
766 77         80 my $code = $self->{code};
767 77 50       143 if (my @plugins = @classstate_plugins) {
768 0     0   0 $code = sub { $self->_run_code_via_plugins(@plugins) };
  0         0  
769 0         0 @classstate_plugins = ();
770             }
771              
772 77 100       92 if ($classstate_use_subtest) {
773 35         26 my $level = $Test::Builder::Level + $Level + 1;
774 35         28 local $Test::Builder::Level = $level;
775             $self->{result} = Test::Builder->new->subtest(
776             $self->{name} => sub {
777 35     35   9130 $code->();
778 35         7828 Test::Builder->new->done_testing;
779              
780             # Work around a flaw in Test::Builder 0.94, see
781             # http://code.google.com/p/test-more/issues/detail?id=58
782 35         1341 $Test::Builder::Level = $level + 2;
783             }
784 35         46 );
785             } else {
786             # Reset $Test::Builder::Level to the default when running the inner
787             # test code. Otherwise, the file/line diagnostics of failing tests
788             # within the group would be messed up if test() is called with a
789             # non-default $Test::Builder::Level value.
790 42         52 local $Test::Builder::Level = 1;
791              
792 42         70 $self->_hijack(); # BEGIN CRITICAL SECTION
793 42         84 my $exception_raised = !
794             $self->_run_with_local_TODO($self->{callerpackage}, $code);
795 42         84 $self->_unhijack(); # END CRITICAL SECTION
796              
797 42 100       87 if ($exception_raised) {
798 5 50       12 if ($classstate_catchexceptions) {
799 5         12 $self->_record_exception();
800             } else {
801 0         0 die $@; # Rethrow
802             }
803             }
804             }
805              
806 77         11722 return; # No useful return value yet
807             }
808              
809             =head3 current ()
810              
811             =head3 current ($newcurrent)
812              
813             Class method, gets or sets the current instance of
814             I w.r.t. the current state of the L
815             / L call stack. If the stack is empty, returns undef.
816              
817             =cut
818              
819             {
820             my $current;
821              
822             sub current {
823 1300 100   1300   1629 if (@_ == 1) {
824 1216         1558 return $current;
825             } else {
826 84         104 $current = $_[1];
827             }
828             }
829             }
830              
831             =head3 orig_blessed ()
832              
833             Returns the class in which C<< Test::Builder->new >> was originally
834             blessed just before it got Led: this will usually be
835             C, unless something really big happens to Perl's
836             testing infrastructure.
837              
838             =cut
839              
840             sub orig_blessed {
841 0     0   0 my $self = shift;
842 0 0       0 return $self->{reblessed_from} if defined $self->{reblessed_from};
843             # Calls recursively:
844 0 0       0 return $self->{parent}->orig_blessed if defined $self->{parent};
845 0         0 return; # Object not completely constructed, should not happen
846             }
847              
848             =head3 mute ()
849              
850             =head3 mute ($bool)
851              
852             Gets or sets the mute status (false by default). This method is not
853             (yet) made visible from L proper; it is used in the test
854             suite (see L) so as not to scare the systems
855             administrator with lots of (expected) failure messages at C
856             test> time.
857              
858             =cut
859              
860             sub mute {
861 85     85   178 my ($self, @mute) = @_;
862 85 100       122 if (@mute) {
863 45         92 $self->{mute} = $mute[0];
864             } else {
865 40         129 return $self->{mute};
866             }
867             }
868              
869             =head3 ok ($status)
870              
871             =head3 ok ($status, $testname)
872              
873             =head3 skip ($reason)
874              
875             Called from within the group subs by virtue of
876             L delegating both
877             methods to us. Works like L
878             resp. L, except that the test results are stashed
879             away as part of the group result instead of being printed at once.
880              
881             =cut
882              
883             # The code was copied over from L, and then
884             # simplified and refactored.
885             sub ok {
886 1060     1060   867 my ($self, $status, $testname) = @_;
887              
888             # Coerce the arguments into being actual scalars (not objects)
889 1060 100       1253 $status = $status ? 1 : 0;
890 1060 100       1325 $testname = substr($testname, 0) if defined $testname; # Stringifies
891              
892             # Use the actual Test::Builder->todo to get at the TODO status.
893             # This is both elegant and necessary for recursion, because
894             # L localizes this same method in order to fool
895             # Test::Builder about the TODO state.
896 1060         1475 my $T = Test::Builder->new;
897 1060         3479 my($pack, $file, $line) = $T->caller;
898              
899 1060   100     13201 my $todo = $T->todo($pack) || undef;
900 1060 100       10817 $todo = substr($todo, 0) if $todo; # Stringifies
901              
902 1060         1649 my $result = { status => $status };
903 1060 100       1290 $result->{todo} = $todo if defined($todo);
904 1060         715 push @{$self->{subtests}}, $result;
  1060         1262  
905              
906 1060 50 33     1441 if ($classstate_verbose and $classstate_verbose >= 2) {
907 0         0 my $nums .= $self->_fully_qualified_test_number;
908 0 0       0 if ($nums =~ tr/.// < $classstate_verbose) {
909 0 0       0 my $line = ($status ? '' : 'not ') . "ok $nums";
910 0 0       0 $line .= " $testname" if defined $testname;
911 0         0 $T->diag($line);
912             }
913             }
914              
915             # Report failures only, as Test::Builder would
916 1060 50 66     1231 if( ! $status && ! $self->mute ) {
917 0 0       0 my $msg = $todo ? "Failed (TODO)" : "Failed";
918              
919 0 0       0 if( defined $testname ) {
920 0         0 $T->diag(qq[ $msg test '$testname'\n]);
921 0 0       0 unless ($InPredicate) {
922 0         0 $T->diag(qq[ in $file at line $line.\n]);
923             }
924             } else {
925 0         0 $T->diag(qq[ $msg test in $file at line $line.\n]);
926             }
927             }
928              
929 1060         10289 return $status;
930             }
931              
932              
933             sub skip {
934 3     3   5 my ($self, $reason) = @_;
935 3         3 push @{$self->{subtests}}, { status => 1 };
  3         16  
936             }
937              
938             =head3 diag (@messages)
939              
940             Called from within the group subs by virtue of
941             L delegating it
942             to us. If this runner object is L, does nothing; otherwise,
943             works like L.
944              
945             =cut
946              
947             sub diag {
948 3     3   5 my ($self, @msgs) = @_;
949 3 50       12 return if ($self->{mute});
950 0         0 my $origdiag = Test::Builder->can("diag");
951 0         0 $origdiag->(Test::Builder->new, @msgs);
952             }
953              
954             =head3 subtests ()
955              
956             After the test is run, returns a list of hash references, each
957             indicating the status of a subtest that ran during L. The
958             following keys may be set in each returned hash:
959              
960             =over
961              
962             =item I (always)
963              
964             A boolean indicating whether the subtest was successful.
965              
966             =item I (may not exist)
967              
968             A string indicating an excuse why the test might have failed.
969              
970             =back
971              
972             In scalar context, returns the number of subtests that occured in the
973             group run.
974              
975             The list of I is appended to by L as the test group
976             progresses.
977              
978             =cut
979              
980 296     296   191 sub subtests { @{shift->{subtests}} }
  296         1004  
981              
982             =head3 unexcused_failure_subtests ()
983              
984             Returns the subset of the L that have a false I and
985             no I. Such tests cause the test group to fail as a whole. In
986             scalar context, returns the number of such unexcused failures.
987              
988             =cut
989              
990             sub unexcused_failure_subtests {
991 88   100 88   104 grep { (! $_->{status}) && ! exists($_->{todo}) }
  3150         4606  
992             (shift->subtests);
993             }
994              
995             =head3 unexpected_success_subtests ()
996              
997             Returns the subset of the L that have a true I and
998             also a I. Such tests are called B and are
999             signaled both by L and I (see respectively
1000             L and L). In scalar context,
1001             returns the number of such unexpected successes.
1002              
1003             =cut
1004              
1005             sub unexpected_success_subtests {
1006 69 100   69   80 grep { $_->{status} && exists($_->{todo}) } (shift->subtests);
  3107         6836  
1007             }
1008              
1009             =head3 todo_subtests ()
1010              
1011             Returns the subset of the L that have a I, regardless
1012             of whether they are L.
1013              
1014             =cut
1015              
1016             sub todo_subtests {
1017 49     49   62 grep { exists $_->{todo} } (shift->subtests)
  3069         2514  
1018             }
1019              
1020             =head3 got_exception ()
1021              
1022             Returns true iff there was an exception raised while the test group
1023             sub ran (that is, whether L was called once for
1024             this object).
1025              
1026             =cut
1027              
1028 155     155   422 sub got_exception { defined shift->{exception} }
1029              
1030             =head3 exception ()
1031              
1032             Returns the value of the exception passed to L.
1033             Note that it is possible for I to return undef, yet
1034             I to return true (that is, an exception whose value
1035             is undef): this can happen when a DESTROY block that runs after the
1036             initial exception in turn throws another exception (remedy: one should
1037             use "local $@;" at the beginning of every sub DESTROY).
1038              
1039             =cut
1040              
1041 1     1   2 sub exception { shift->{exception} }
1042              
1043             =head3 is_skipped ()
1044              
1045             Returns true iff this test was skipped and did not actually run.
1046              
1047             =head3 skip_reason ()
1048              
1049             Returns the reason that was stipulated by the test writer for skipping
1050             this test. Note that I may be undef even if
1051             L is true.
1052              
1053             =cut
1054              
1055 257     257   10396 sub is_skipped { exists shift->{skipreason} }
1056 3     3   11 sub skip_reason { shift->{skipreason} }
1057              
1058             =head3 as_Test_Builder_params ()
1059              
1060             Returns a ($OK_status, $TODO_string) pair that sums up what we should
1061             tell L about this test (assuming that it actually ran,
1062             as opposed to L tests). The returned values implement
1063             the algorithm detailed in L; they are designed to be used
1064             respectively as the first parameter to L, and as
1065             what L should be tricked into returning during the
1066             call to said I<< Test::Builder->ok >> (have a look at the source code
1067             for L if you want to see that trick in action).
1068              
1069             I will do its best to sum up the status of the
1070             multiple tests ran inside this group into what amounts to a single
1071             call to L, according to the following table:
1072              
1073             Situation $OK_status defined($TODO_string)
1074              
1075             Real success true false
1076              
1077             Success, but TODOs seen false true
1078             within the group
1079              
1080             Unexpected TODO success(es) true true
1081             within the group
1082              
1083             Failed test in group, false false
1084             or no tests run at all
1085              
1086             Finally, if the test group as a whole is running in a TODO context (by
1087             virtue of $TODO being defined at L invocation time, or the test
1088             having the word TODO in the name, as discussed in L),
1089             $TODO_string will be set if it isn't already, possibly transforming
1090             the fate of the test group accordingly.
1091              
1092             =cut
1093              
1094             sub as_Test_Builder_params {
1095 105     105   255 my ($self) = @_;
1096              
1097 105 50       170 die <<"MESSAGE" if ! wantarray;
1098             INCORRECT CALL: array context only for this method.
1099             MESSAGE
1100              
1101 105         81 my ($OK, $TODO_string);
1102 105 50 100     128 if ($self->is_skipped) {
    100 100        
    100          
    100          
1103 0         0 die <<"MESSAGE";
1104             INCORRECT CALL: this method should not be called for skipped tests
1105             MESSAGE
1106             } elsif ($self->got_exception ||
1107             !($self->subtests) ||
1108             $self->unexcused_failure_subtests) {
1109 54         62 ($OK, $TODO_string) = (0, undef);
1110             } elsif ($self->unexpected_success_subtests) {
1111 18         21 ($OK, $TODO_string) = (1, $self->_make_todo_string
1112             ($self->unexpected_success_subtests));
1113             } elsif ($self->todo_subtests) {
1114 16         25 ($OK, $TODO_string) =
1115             (0, $self->_make_todo_string($self->todo_subtests));
1116             } else {
1117 17         24 ($OK, $TODO_string) = (1, undef); # Hurray!
1118             }
1119 105 100       345 if (! defined $TODO_string) {
1120 71 100       182 $TODO_string = $self->{name} if $self->{name} =~ m/\bTODO\b/;
1121 71 100       142 $TODO_string = $self->{in_todo} if $self->{in_todo};
1122             }
1123 105         192 return ($OK, $TODO_string);
1124             }
1125              
1126             =head3 _hijack ()
1127              
1128             Hijacks L for the time the test group sub is being run,
1129             so that we may capture the calls to L and friends
1130             made from within the group sub. L cancels this behavior.
1131              
1132             When called while L is undef, C<< Test::Builder->new >> is
1133             (ahem) temporarily reblessed into the
1134             I package, so that any method
1135             calls performed subsequently against it will be routed through
1136             L where they can
1137             be tampered with at will. This works even if third-party code
1138             happened to hold a reference to C<< Test::Builder->new >> before
1139             I<_hijack> was called.
1140              
1141             If on the other hand L was already defined before entering
1142             I<_hijack>, then a B is performed: this is to support
1143             nested L group subs. In this case, the returned object behaves
1144             mostly like the first return value of I<_hijack> except that its
1145             L method has no effect.
1146              
1147             =cut
1148              
1149             sub _hijack {
1150 42     42   38 my ($self) = @_;
1151              
1152 42         55 my $class = ref($self);
1153 42 100       56 if (defined $class->current) { # Nested hijack
1154 11         17 $self->{parent} = $class->current;
1155             } else { # Top-level hijack
1156 31         64 $self->{orig_testbuilder} = Test::Builder->new;
1157 31         150 $self->{reblessed_from} = ref($self->{orig_testbuilder});
1158 31         70 bless($self->{orig_testbuilder},
1159             "Test::Builder::_HijackedByTestGroup");
1160             }
1161              
1162             # The following line of code must be executed immediately after
1163             # the reblessing above, as the delegating stubs (L, L
1164             # and L below) need ->current() to be set to work:
1165 42         67 $class->current($self);
1166             }
1167              
1168             =head3 _unhijack ()
1169              
1170             Unbuggers the C<< Test::Builder->new >> singleton that was reblessed
1171             by L, so that it may resume being itself, or pops one item
1172             from the L stack in case of a nested hijack.
1173              
1174             =cut
1175              
1176             sub _unhijack {
1177 42     42   42 my ($self) = @_;
1178 42 100       70 if (defined($self->{orig_testbuilder})) { # Top-level unhijack
1179 31         54 $self->current(undef);
1180 31         64 bless $self->{orig_testbuilder}, $self->{reblessed_from};
1181             } else {
1182             # Nested unhijack
1183 11         23 $self->current($self->{parent});
1184             }
1185 42         33 1;
1186             }
1187              
1188             =head3 _fully_qualified_test_number ()
1189              
1190             Returns the compound number of the current test, fully qualified
1191             from the outer L test down into the current test
1192             group, with numbers joined with dots.
1193              
1194             =cut
1195              
1196             sub _fully_qualified_test_number {
1197 0     0   0 my $self = shift;
1198              
1199 0         0 my @nums;
1200 0         0 my $runner = $self->current;
1201 0         0 while ($runner) {
1202 0         0 unshift @nums, 1+scalar $runner->subtests;
1203 0         0 $runner = $runner->{parent};
1204             }
1205 0 0       0 --$nums[-1] if @nums;
1206 0         0 return join '.', 1+Test::Builder->new->current_test, @nums;
1207             }
1208              
1209             =head3 _run_with_local_TODO ($callerpackage, $sub)
1210              
1211             Invokes the test sub $sub while temporarily setting the variable
1212             C<${${callerpackage}::TODO}> to undef, thereby implementing the
1213             local-TODO semantics described in L. Returns true if
1214             $sub completed, and false if $sub threw an exception (that is
1215             thereafter available in $@ as usual).
1216              
1217             I<_run_with_local_TODO> is guaranteed not to throw an exception
1218             itself, so that it is safe to use it in a critical section opened by
1219             calling L and closed by calling L.
1220              
1221             =cut
1222              
1223             sub _run_with_local_TODO {
1224 42     42   48 my ($self, $callerpackage, $sub) = @_;
1225             ## Locally sets $TODO to undef, see POD snippet "TODO gotcha 2".
1226             ## I used to do
1227             # no strict 'refs';
1228             # local ${$callerpackage . '::TODO' };
1229             ## but this doesn't work in 5.6 ("Can't localize through a reference")
1230 12     12   66 my $TODOref = do { no strict "refs"; \${$callerpackage . '::TODO' } };
  12         19  
  12         2679  
  42         36  
  42         30  
  42         88  
1231 42         42 my $TODOorig = $$TODOref;
1232 42         37 $$TODOref = undef;
1233              
1234 42         50 my $retval = eval { $sub->(); 1; };
  42         243  
  37         81  
1235 42         86 $$TODOref = $TODOorig;
1236 42         65 return $retval;
1237             }
1238              
1239             =head3 _run_code_via_plugins (@plugins)
1240              
1241             Invokes the subroutine reference stored as C<$self->{code}> via
1242             the chain of plugins in C<@plugins>.
1243              
1244             =cut
1245              
1246             sub _run_code_via_plugins {
1247 0     0   0 my ($self, $plugin, @more) = @_;
1248              
1249 0 0       0 if ($plugin) {
1250 0         0 my $old_inp = $InPredicate;
1251 0         0 local $InPredicate = 1;
1252             $plugin->(sub{
1253 0     0   0 local $InPredicate = $old_inp;
1254 0         0 $self->_run_code_via_plugins(@more);
1255 0         0 });
1256             } else {
1257 0         0 $self->{code}->();
1258             }
1259             }
1260              
1261             =head3 _skip ($reason)
1262              
1263             Private setter called from L when the test sub is not to be
1264             called at all. $reason is the reason why the test is being skipped
1265             (probable causes are L, L,
1266             L and friends).
1267              
1268             =cut
1269              
1270             sub _skip {
1271 6     6   9 my ($self, $reason) = @_;
1272              
1273 6         16 $self->{skipreason} = $reason;
1274             }
1275              
1276             =head3 _record_exception ()
1277              
1278             Memorizes the exception that was raised by the group sub that just
1279             run. The exception is looked for in variables C<$@> and
1280             C<$Error::THROWN>. TODO: add support for other popular exception
1281             management classes.
1282              
1283             =cut
1284              
1285             sub _record_exception {
1286 5     5   6 my ($self) = @_;
1287 5 0 33     46 $self->{exception} =
    50          
1288             ( (ref($@) || (defined($@) && length($@) > 0)) ? $@ :
1289             # Factor L in (TODO: add L as
1290             # well):
1291             defined($Error::THROWN) ? $Error::THROWN :
1292             undef );
1293             }
1294              
1295             =head3 _make_todo_string (@subtests)
1296              
1297             Pretty-prints an appropriate string to return as the second element in
1298             the returned list on behalf of L. @subtests
1299             are the TODO sub-tests that the caller wants to talk about (depending
1300             on the situation, that would be all the L, or only the
1301             L).
1302              
1303             =cut
1304              
1305             sub _make_todo_string {
1306 34     34   48 my ($self, @subtests) = @_;
1307 34 50       37 return join(", ", map { $_->{todo} || "(no TODO explanation)" }
  37         140  
1308             @subtests);
1309             }
1310              
1311             =head2 Test::Builder::_HijackedByTestGroup internal class
1312              
1313             This is an internal subclass of L used as an accomplice
1314             by L to hijack the method calls performed upon the
1315             Test::Builder singleton (see L) by the various
1316             testing modules from the CPAN, e.g. L, L and
1317             friends. It works almost the same as the real thing, except for the
1318             following method calls:
1319              
1320             =cut
1321              
1322             package Test::Builder::_HijackedByTestGroup;
1323 12     12   54 use base "Test::Builder";
  12         15  
  12         1284  
1324              
1325             =head3 ok ()
1326              
1327             =head3 skip ()
1328              
1329             =head3 diag ()
1330              
1331             These methods are delegated to the L instance of
1332             I.
1333              
1334             =cut
1335              
1336             foreach my $delegated (qw(ok skip diag)) {
1337 12     12   52 no strict "refs";
  12         15  
  12         1251  
1338             *{$delegated} = sub {
1339 1066     1066   9130 my $self = shift;
1340 1066         1456 unshift(@_, Test::Group::_Runner->current);
1341 1066         725 goto &{"Test::Group::_Runner::".$delegated};
  1066         2581  
1342             };
1343             }
1344              
1345             =end internals
1346              
1347             =head1 BUGS
1348              
1349             This class uses a somewhat unhealthy dose of black magic to take over
1350             control from L when running inside a L group
1351             sub. While the temporary re-blessing trick used therein is thought to
1352             be very robust, it is not very elegant.
1353              
1354             The experimental use_subtest() feature allows you to avoid the black
1355             magic if your L is recent enough to support subtests.
1356              
1357             =head1 SEE ALSO
1358              
1359             L, L, L, and friends
1360              
1361             The C project, L.
1362              
1363             =head2 Similar modules on CPAN
1364              
1365             L can be used to turn a test suite into a full-fledged
1366             object class of its own, in xUnit style. It also happens to support a
1367             similar form of test grouping using the C<:Test(no_plan)> or C<:Tests>
1368             attributes. Switching over to I will make a test suite
1369             more rugged and provide a number of advantages, but it will also
1370             dilute the "quick-and-dirty" aspect of .t files somewhat. This may or
1371             may not be what you want: for example, the author of this module
1372             enjoys programming most when writing tests, because the most infamous
1373             Perl hacks are par for the course then :-). Anyway TIMTOWTDI, and
1374             I is a way to reap some of the benefits of I
1375             (e.g. running only part of the test suite) without changing one's
1376             programming style too much.
1377              
1378             =head1 AUTHORS
1379              
1380             Nick Cleaton
1381              
1382             Dominique Quatravaux
1383              
1384             Nicolas M. ThiEry
1385              
1386             =head1 LICENSE
1387              
1388             Copyright (C) 2004 by IDEALX
1389              
1390             Copyright (c) 2009 by Nick Cleaton and Dominique Quatravaux
1391              
1392             This library is free software; you can redistribute it and/or modify
1393             it under the same terms as Perl itself, either Perl version 5.8.1 or,
1394             at your option, any later version of Perl 5 you may have available.
1395              
1396             =cut
1397              
1398             1;