File Coverage

lib/Test/Tester.pm
Criterion Covered Total %
statement 98 123 79.6
branch 20 38 52.6
condition 5 12 41.6
subroutine 19 22 86.3
pod 6 13 46.1
total 148 208 71.1


line stmt bran cond sub pod time code
1 6     6   5696 use strict;
  6         41  
  6         360  
2              
3             package Test::Tester;
4              
5             BEGIN
6             {
7 6 100   6   119 if (*Test::Builder::new{CODE})
8             {
9 1         22 warn "You should load Test::Tester before Test::Builder (or anything that loads Test::Builder)"
10             }
11             }
12              
13 6     6   3071 use Test::Builder;
  6         19  
  6         211  
14 6     6   2673 use Test::Tester::CaptureRunner;
  6         18  
  6         187  
15 6     6   2332 use Test::Tester::Delegate;
  6         17  
  6         225  
16              
17             require Exporter;
18              
19 6     6   49 use vars qw( @ISA @EXPORT );
  6         14  
  6         9813  
20              
21             our $VERSION = '1.302181';
22              
23             @EXPORT = qw( run_tests check_tests check_test cmp_results show_space );
24             @ISA = qw( Exporter );
25              
26             my $Test = Test::Builder->new;
27             my $Capture = Test::Tester::Capture->new;
28             my $Delegator = Test::Tester::Delegate->new;
29             $Delegator->{Object} = $Test;
30              
31             my $runner = Test::Tester::CaptureRunner->new;
32              
33             my $want_space = $ENV{TESTTESTERSPACE};
34              
35             sub show_space
36             {
37 0     0 1 0 $want_space = 1;
38             }
39              
40             my $colour = '';
41             my $reset = '';
42              
43             if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{TESTTESTERCOLOR})
44             {
45             if (eval { require Term::ANSIColor; 1 })
46             {
47             eval { require Win32::Console::ANSI } if 'MSWin32' eq $^O; # support color on windows platforms
48             my ($f, $b) = split(",", $want_colour);
49             $colour = Term::ANSIColor::color($f).Term::ANSIColor::color("on_$b");
50             $reset = Term::ANSIColor::color("reset");
51             }
52              
53             }
54              
55             sub new_new
56             {
57 7     7 0 3085 return $Delegator;
58             }
59              
60             sub capture
61             {
62 3     3 0 46 return Test::Tester::Capture->new;
63             }
64              
65             sub fh
66             {
67             # experiment with capturing output, I don't like it
68 0     0 0 0 $runner = Test::Tester::FHRunner->new;
69              
70 0         0 return $Test;
71             }
72              
73             sub find_run_tests
74             {
75 26     26 0 37 my $d = 1;
76 26         38 my $found = 0;
77 26   66     177 while ((not $found) and (my ($sub) = (caller($d))[3]) )
78             {
79             # print "$d: $sub\n";
80 109         167 $found = ($sub eq "Test::Tester::run_tests");
81 109         406 $d++;
82             }
83              
84             # die "Didn't find 'run_tests' in caller stack" unless $found;
85 26         94 return $d;
86             }
87              
88             sub run_tests
89             {
90 18     18 1 162 local($Delegator->{Object}) = $Capture;
91              
92 18         76 $runner->run_tests(@_);
93              
94 18         62 return ($runner->get_premature, $runner->get_results);
95             }
96              
97             sub check_test
98             {
99 8     8 1 787 my $test = shift;
100 8         14 my $expect = shift;
101 8         13 my $name = shift;
102 8 50       19 $name = "" unless defined($name);
103              
104 8         25 @_ = ($test, [$expect], $name);
105 8         26 goto &check_tests;
106             }
107              
108             sub check_tests
109             {
110 9     9 1 163 my $test = shift;
111 9         16 my $expects = shift;
112 9         12 my $name = shift;
113 9 50       32 $name = "" unless defined($name);
114              
115 9         13 my ($prem, @results) = eval { run_tests($test, $name) };
  9         18  
116              
117 9 50       71 $Test->ok(! $@, "Test '$name' completed") || $Test->diag($@);
118 9 50       40 $Test->ok(! length($prem), "Test '$name' no premature diagnostication") ||
119             $Test->diag("Before any testing anything, your tests said\n$prem");
120              
121 9         20 local $Test::Builder::Level = $Test::Builder::Level + 1;
122 9         28 cmp_results(\@results, $expects, $name);
123 9         268 return ($prem, @results);
124             }
125              
126             sub cmp_field
127             {
128 80     80 0 126 my ($result, $expect, $field, $desc) = @_;
129              
130 80 50       166 if (defined $expect->{$field})
131             {
132 80         264 $Test->is_eq($result->{$field}, $expect->{$field},
133             "$desc compare $field");
134             }
135             }
136              
137             sub cmp_result
138             {
139 16     16 1 28 my ($result, $expect, $name) = @_;
140              
141 16         29 my $sub_name = $result->{name};
142 16 50       27 $sub_name = "" unless defined($name);
143              
144 16         38 my $desc = "subtest '$sub_name' of '$name'";
145              
146             {
147 16         18 local $Test::Builder::Level = $Test::Builder::Level + 1;
  16         22  
148              
149 16         37 cmp_field($result, $expect, "ok", $desc);
150              
151 16         39 cmp_field($result, $expect, "actual_ok", $desc);
152              
153 16         41 cmp_field($result, $expect, "type", $desc);
154              
155 16         43 cmp_field($result, $expect, "reason", $desc);
156              
157 16         40 cmp_field($result, $expect, "name", $desc);
158             }
159              
160             # if we got no depth then default to 1
161 16         26 my $depth = 1;
162 16 50       38 if (exists $expect->{depth})
163             {
164 16         24 $depth = $expect->{depth};
165             }
166              
167             # if depth was explicitly undef then don't test it
168 16 50       30 if (defined $depth)
169             {
170 16 50       39 $Test->is_eq($result->{depth}, $depth, "checking depth") ||
171             $Test->diag('You need to change $Test::Builder::Level');
172             }
173              
174 16 50       47 if (defined(my $exp = $expect->{diag}))
175             {
176              
177 16         21 my $got = '';
178 16 100       40 if (ref $exp eq 'Regexp') {
179              
180 4 50       22 if (not $Test->like($result->{diag}, $exp,
181             "subtest '$sub_name' of '$name' compare diag"))
182             {
183 0         0 $got = $result->{diag};
184             }
185              
186             } else {
187              
188             # if there actually is some diag then put a \n on the end if it's not
189             # there already
190 12 100 100     51 $exp .= "\n" if (length($exp) and $exp !~ /\n$/);
191              
192 12 50       47 if (not $Test->ok($result->{diag} eq $exp,
193             "subtest '$sub_name' of '$name' compare diag"))
194             {
195 0         0 $got = $result->{diag};
196             }
197             }
198              
199 16 50       75 if ($got) {
200 0         0 my $glen = length($got);
201 0         0 my $elen = length($exp);
202 0         0 for ($got, $exp)
203             {
204 0         0 my @lines = split("\n", $_);
205             $_ = join("\n", map {
206 0 0       0 if ($want_space)
  0         0  
207             {
208 0         0 $_ = $colour.escape($_).$reset;
209             }
210             else
211             {
212 0         0 "'$colour$_$reset'"
213             }
214             } @lines);
215             }
216              
217 0         0 $Test->diag(<<EOM);
218             Got diag ($glen bytes):
219             $got
220             Expected diag ($elen bytes):
221             $exp
222             EOM
223             }
224             }
225             }
226              
227             sub escape
228             {
229 0     0 0 0 my $str = shift;
230 0         0 my $res = '';
231 0         0 for my $char (split("", $str))
232             {
233 0         0 my $c = ord($char);
234 0 0 0     0 if(($c>32 and $c<125) or $c == 10)
      0        
235             {
236 0         0 $res .= $char;
237             }
238             else
239             {
240 0         0 $res .= sprintf('\x{%x}', $c)
241             }
242             }
243 0         0 return $res;
244             }
245              
246             sub cmp_results
247             {
248 9     9 1 18 my ($results, $expects, $name) = @_;
249              
250 9         40 $Test->is_num(scalar @$results, scalar @$expects, "Test '$name' result count");
251              
252 9         28 for (my $i = 0; $i < @$expects; $i++)
253             {
254 16         29 my $expect = $expects->[$i];
255 16         24 my $result = $results->[$i];
256              
257 16         25 local $Test::Builder::Level = $Test::Builder::Level + 1;
258 16         29 cmp_result($result, $expect, $name);
259             }
260             }
261              
262             ######## nicked from Test::More
263             sub plan {
264 5     5 0 15 my(@plan) = @_;
265              
266 5         12 my $caller = caller;
267              
268 5         35 $Test->exported_to($caller);
269              
270 5         9 my @imports = ();
271 5         27 foreach my $idx (0..$#plan) {
272 2 50       8 if( $plan[$idx] eq 'import' ) {
273 0         0 my($tag, $imports) = splice @plan, $idx, 2;
274 0         0 @imports = @$imports;
275 0         0 last;
276             }
277             }
278              
279 5         35 $Test->plan(@plan);
280              
281 5         17 __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
282             }
283              
284             sub import {
285 5     5   50 my($class) = shift;
286             {
287 6     6   68 no warnings 'redefine';
  6         13  
  6         968  
  5         11  
288 5         63 *Test::Builder::new = \&new_new;
289             }
290 5         31 goto &plan;
291             }
292              
293             sub _export_to_level
294             {
295 5     5   11 my $pkg = shift;
296 5         8 my $level = shift;
297 5         9 (undef) = shift; # redundant arg
298 5         10 my $callpkg = caller($level);
299 5         668 $pkg->export($callpkg, @_);
300             }
301              
302              
303             ############
304              
305             1;
306              
307             __END__
308              
309             =head1 NAME
310              
311             Test::Tester - Ease testing test modules built with Test::Builder
312              
313             =head1 SYNOPSIS
314              
315             use Test::Tester tests => 6;
316              
317             use Test::MyStyle;
318              
319             check_test(
320             sub {
321             is_mystyle_eq("this", "that", "not eq");
322             },
323             {
324             ok => 0, # expect this to fail
325             name => "not eq",
326             diag => "Expected: 'this'\nGot: 'that'",
327             }
328             );
329              
330             or
331              
332             use Test::Tester tests => 6;
333              
334             use Test::MyStyle;
335              
336             check_test(
337             sub {
338             is_mystyle_qr("this", "that", "not matching");
339             },
340             {
341             ok => 0, # expect this to fail
342             name => "not matching",
343             diag => qr/Expected: 'this'\s+Got: 'that'/,
344             }
345             );
346              
347             or
348              
349             use Test::Tester;
350              
351             use Test::More tests => 3;
352             use Test::MyStyle;
353              
354             my ($premature, @results) = run_tests(
355             sub {
356             is_database_alive("dbname");
357             }
358             );
359              
360             # now use Test::More::like to check the diagnostic output
361              
362             like($results[0]->{diag}, "/^Database ping took \\d+ seconds$"/, "diag");
363              
364             =head1 DESCRIPTION
365              
366             If you have written a test module based on Test::Builder then Test::Tester
367             allows you to test it with the minimum of effort.
368              
369             =head1 HOW TO USE (THE EASY WAY)
370              
371             From version 0.08 Test::Tester no longer requires you to included anything
372             special in your test modules. All you need to do is
373              
374             use Test::Tester;
375              
376             in your test script B<before> any other Test::Builder based modules and away
377             you go.
378              
379             Other modules based on Test::Builder can be used to help with the
380             testing. In fact you can even use functions from your module to test
381             other functions from the same module (while this is possible it is
382             probably not a good idea, if your module has bugs, then
383             using it to test itself may give the wrong answers).
384              
385             The easiest way to test is to do something like
386              
387             check_test(
388             sub { is_mystyle_eq("this", "that", "not eq") },
389             {
390             ok => 0, # we expect the test to fail
391             name => "not eq",
392             diag => "Expected: 'this'\nGot: 'that'",
393             }
394             );
395              
396             this will execute the is_mystyle_eq test, capturing its results and
397             checking that they are what was expected.
398              
399             You may need to examine the test results in a more flexible way, for
400             example, the diagnostic output may be quite long or complex or it may involve
401             something that you cannot predict in advance like a timestamp. In this case
402             you can get direct access to the test results:
403              
404             my ($premature, @results) = run_tests(
405             sub {
406             is_database_alive("dbname");
407             }
408             );
409              
410             like($result[0]->{diag}, "/^Database ping took \\d+ seconds$"/, "diag");
411              
412             or
413              
414             check_test(
415             sub { is_mystyle_qr("this", "that", "not matching") },
416             {
417             ok => 0, # we expect the test to fail
418             name => "not matching",
419             diag => qr/Expected: 'this'\s+Got: 'that'/,
420             }
421             );
422              
423             We cannot predict how long the database ping will take so we use
424             Test::More's like() test to check that the diagnostic string is of the right
425             form.
426              
427             =head1 HOW TO USE (THE HARD WAY)
428              
429             I<This is here for backwards compatibility only>
430              
431             Make your module use the Test::Tester::Capture object instead of the
432             Test::Builder one. How to do this depends on your module but assuming that
433             your module holds the Test::Builder object in $Test and that all your test
434             routines access it through $Test then providing a function something like this
435              
436             sub set_builder
437             {
438             $Test = shift;
439             }
440              
441             should allow your test scripts to do
442              
443             Test::YourModule::set_builder(Test::Tester->capture);
444              
445             and after that any tests inside your module will captured.
446              
447             =head1 TEST RESULTS
448              
449             The result of each test is captured in a hash. These hashes are the same as
450             the hashes returned by Test::Builder->details but with a couple of extra
451             fields.
452              
453             These fields are documented in L<Test::Builder> in the details() function
454              
455             =over 2
456              
457             =item ok
458              
459             Did the test pass?
460              
461             =item actual_ok
462              
463             Did the test really pass? That is, did the pass come from
464             Test::Builder->ok() or did it pass because it was a TODO test?
465              
466             =item name
467              
468             The name supplied for the test.
469              
470             =item type
471              
472             What kind of test? Possibilities include, skip, todo etc. See
473             L<Test::Builder> for more details.
474              
475             =item reason
476              
477             The reason for the skip, todo etc. See L<Test::Builder> for more details.
478              
479             =back
480              
481             These fields are exclusive to Test::Tester.
482              
483             =over 2
484              
485             =item diag
486              
487             Any diagnostics that were output for the test. This only includes
488             diagnostics output B<after> the test result is declared.
489              
490             Note that Test::Builder ensures that any diagnostics end in a \n and
491             it in earlier versions of Test::Tester it was essential that you have
492             the final \n in your expected diagnostics. From version 0.10 onward,
493             Test::Tester will add the \n if you forgot it. It will not add a \n if
494             you are expecting no diagnostics. See below for help tracking down
495             hard to find space and tab related problems.
496              
497             =item depth
498              
499             This allows you to check that your test module is setting the correct value
500             for $Test::Builder::Level and thus giving the correct file and line number
501             when a test fails. It is calculated by looking at caller() and
502             $Test::Builder::Level. It should count how many subroutines there are before
503             jumping into the function you are testing. So for example in
504              
505             run_tests( sub { my_test_function("a", "b") } );
506              
507             the depth should be 1 and in
508              
509             sub deeper { my_test_function("a", "b") }
510              
511             run_tests(sub { deeper() });
512              
513             depth should be 2, that is 1 for the sub {} and one for deeper(). This
514             might seem a little complex but if your tests look like the simple
515             examples in this doc then you don't need to worry as the depth will
516             always be 1 and that's what Test::Tester expects by default.
517              
518             B<Note>: if you do not specify a value for depth in check_test() then it
519             automatically compares it against 1, if you really want to skip the depth
520             test then pass in undef.
521              
522             B<Note>: depth will not be correctly calculated for tests that run from a
523             signal handler or an END block or anywhere else that hides the call stack.
524              
525             =back
526              
527             Some of Test::Tester's functions return arrays of these hashes, just
528             like Test::Builder->details. That is, the hash for the first test will
529             be array element 1 (not 0). Element 0 will not be a hash it will be a
530             string which contains any diagnostic output that came before the first
531             test. This should usually be empty, if it's not, it means something
532             output diagnostics before any test results showed up.
533              
534             =head1 SPACES AND TABS
535              
536             Appearances can be deceptive, especially when it comes to emptiness. If you
537             are scratching your head trying to work out why Test::Tester is saying that
538             your diagnostics are wrong when they look perfectly right then the answer is
539             probably whitespace. From version 0.10 on, Test::Tester surrounds the
540             expected and got diag values with single quotes to make it easier to spot
541             trailing whitespace. So in this example
542              
543             # Got diag (5 bytes):
544             # 'abcd '
545             # Expected diag (4 bytes):
546             # 'abcd'
547              
548             it is quite clear that there is a space at the end of the first string.
549             Another way to solve this problem is to use colour and inverse video on an
550             ANSI terminal, see below COLOUR below if you want this.
551              
552             Unfortunately this is sometimes not enough, neither colour nor quotes will
553             help you with problems involving tabs, other non-printing characters and
554             certain kinds of problems inherent in Unicode. To deal with this, you can
555             switch Test::Tester into a mode whereby all "tricky" characters are shown as
556             \{xx}. Tricky characters are those with ASCII code less than 33 or higher
557             than 126. This makes the output more difficult to read but much easier to
558             find subtle differences between strings. To turn on this mode either call
559             C<show_space()> in your test script or set the C<TESTTESTERSPACE> environment
560             variable to be a true value. The example above would then look like
561              
562             # Got diag (5 bytes):
563             # abcd\x{20}
564             # Expected diag (4 bytes):
565             # abcd
566              
567             =head1 COLOUR
568              
569             If you prefer to use colour as a means of finding tricky whitespace
570             characters then you can set the C<TESTTESTCOLOUR> environment variable to a
571             comma separated pair of colours, the first for the foreground, the second
572             for the background. For example "white,red" will print white text on a red
573             background. This requires the Term::ANSIColor module. You can specify any
574             colour that would be acceptable to the Term::ANSIColor::color function.
575              
576             If you spell colour differently, that's no problem. The C<TESTTESTERCOLOR>
577             variable also works (if both are set then the British spelling wins out).
578              
579             =head1 EXPORTED FUNCTIONS
580              
581             =head3 ($premature, @results) = run_tests(\&test_sub)
582              
583             \&test_sub is a reference to a subroutine.
584              
585             run_tests runs the subroutine in $test_sub and captures the results of any
586             tests inside it. You can run more than 1 test inside this subroutine if you
587             like.
588              
589             $premature is a string containing any diagnostic output from before
590             the first test.
591              
592             @results is an array of test result hashes.
593              
594             =head3 cmp_result(\%result, \%expect, $name)
595              
596             \%result is a ref to a test result hash.
597              
598             \%expect is a ref to a hash of expected values for the test result.
599              
600             cmp_result compares the result with the expected values. If any differences
601             are found it outputs diagnostics. You may leave out any field from the
602             expected result and cmp_result will not do the comparison of that field.
603              
604             =head3 cmp_results(\@results, \@expects, $name)
605              
606             \@results is a ref to an array of test results.
607              
608             \@expects is a ref to an array of hash refs.
609              
610             cmp_results checks that the results match the expected results and if any
611             differences are found it outputs diagnostics. It first checks that the
612             number of elements in \@results and \@expects is the same. Then it goes
613             through each result checking it against the expected result as in
614             cmp_result() above.
615              
616             =head3 ($premature, @results) = check_tests(\&test_sub, \@expects, $name)
617              
618             \&test_sub is a reference to a subroutine.
619              
620             \@expect is a ref to an array of hash refs which are expected test results.
621              
622             check_tests combines run_tests and cmp_tests into a single call. It also
623             checks if the tests died at any stage.
624              
625             It returns the same values as run_tests, so you can further examine the test
626             results if you need to.
627              
628             =head3 ($premature, @results) = check_test(\&test_sub, \%expect, $name)
629              
630             \&test_sub is a reference to a subroutine.
631              
632             \%expect is a ref to an hash of expected values for the test result.
633              
634             check_test is a wrapper around check_tests. It combines run_tests and
635             cmp_tests into a single call, checking if the test died. It assumes
636             that only a single test is run inside \&test_sub and include a test to
637             make sure this is true.
638              
639             It returns the same values as run_tests, so you can further examine the test
640             results if you need to.
641              
642             =head3 show_space()
643              
644             Turn on the escaping of characters as described in the SPACES AND TABS
645             section.
646              
647             =head1 HOW IT WORKS
648              
649             Normally, a test module (let's call it Test:MyStyle) calls
650             Test::Builder->new to get the Test::Builder object. Test::MyStyle calls
651             methods on this object to record information about test results. When
652             Test::Tester is loaded, it replaces Test::Builder's new() method with one
653             which returns a Test::Tester::Delegate object. Most of the time this object
654             behaves as the real Test::Builder object. Any methods that are called are
655             delegated to the real Test::Builder object so everything works perfectly.
656             However once we go into test mode, the method calls are no longer passed to
657             the real Test::Builder object, instead they go to the Test::Tester::Capture
658             object. This object seems exactly like the real Test::Builder object,
659             except, instead of outputting test results and diagnostics, it just records
660             all the information for later analysis.
661              
662             =head1 CAVEATS
663              
664             Support for calling Test::Builder->note is minimal. It's implemented
665             as an empty stub, so modules that use it will not crash but the calls
666             are not recorded for testing purposes like the others. Patches
667             welcome.
668              
669             =head1 SEE ALSO
670              
671             L<Test::Builder> the source of testing goodness. L<Test::Builder::Tester>
672             for an alternative approach to the problem tackled by Test::Tester -
673             captures the strings output by Test::Builder. This means you cannot get
674             separate access to the individual pieces of information and you must predict
675             B<exactly> what your test will output.
676              
677             =head1 AUTHOR
678              
679             This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
680             are based on other people's work.
681              
682             Plan handling lifted from Test::More. written by Michael G Schwern
683             <schwern@pobox.com>.
684              
685             Test::Tester::Capture is a cut down and hacked up version of Test::Builder.
686             Test::Builder was written by chromatic <chromatic@wgz.org> and Michael G
687             Schwern <schwern@pobox.com>.
688              
689             =head1 LICENSE
690              
691             Under the same license as Perl itself
692              
693             See http://www.perl.com/perl/misc/Artistic.html
694              
695             =cut