Synch with CPAN Test-Simple 1.302140.
[perl.git] / cpan / Test-Simple / lib / Test / Tester.pm
1 use strict;
2
3 package Test::Tester;
4
5 BEGIN
6 {
7         if (*Test::Builder::new{CODE})
8         {
9                 warn "You should load Test::Tester before Test::Builder (or anything that loads Test::Builder)"
10         }
11 }
12
13 use Test::Builder;
14 use Test::Tester::CaptureRunner;
15 use Test::Tester::Delegate;
16
17 require Exporter;
18
19 use vars qw( @ISA @EXPORT );
20
21 our $VERSION = '1.302140';
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         $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         return $Delegator;
58 }
59
60 sub capture
61 {
62         return Test::Tester::Capture->new;
63 }
64
65 sub fh
66 {
67         # experiment with capturing output, I don't like it
68         $runner = Test::Tester::FHRunner->new;
69
70         return $Test;
71 }
72
73 sub find_run_tests
74 {
75         my $d = 1;
76         my $found = 0;
77         while ((not $found) and (my ($sub) = (caller($d))[3]) )
78         {
79 #               print "$d: $sub\n";
80                 $found = ($sub eq "Test::Tester::run_tests");
81                 $d++;
82         }
83
84 #       die "Didn't find 'run_tests' in caller stack" unless $found;
85         return $d;
86 }
87
88 sub run_tests
89 {
90         local($Delegator->{Object}) = $Capture;
91
92         $runner->run_tests(@_);
93
94         return ($runner->get_premature, $runner->get_results);
95 }
96
97 sub check_test
98 {
99         my $test = shift;
100         my $expect = shift;
101         my $name = shift;
102         $name = "" unless defined($name);
103
104         @_ = ($test, [$expect], $name);
105         goto &check_tests;
106 }
107
108 sub check_tests
109 {
110         my $test = shift;
111         my $expects = shift;
112         my $name = shift;
113         $name = "" unless defined($name);
114
115         my ($prem, @results) = eval { run_tests($test, $name) };
116
117         $Test->ok(! $@, "Test '$name' completed") || $Test->diag($@);
118         $Test->ok(! length($prem), "Test '$name' no premature diagnostication") ||
119                 $Test->diag("Before any testing anything, your tests said\n$prem");
120
121         local $Test::Builder::Level = $Test::Builder::Level + 1;
122         cmp_results(\@results, $expects, $name);
123         return ($prem, @results);
124 }
125
126 sub cmp_field
127 {
128         my ($result, $expect, $field, $desc) = @_;
129
130         if (defined $expect->{$field})
131         {
132                 $Test->is_eq($result->{$field}, $expect->{$field},
133                         "$desc compare $field");
134         }
135 }
136
137 sub cmp_result
138 {
139         my ($result, $expect, $name) = @_;
140
141         my $sub_name = $result->{name};
142         $sub_name = "" unless defined($name);
143
144         my $desc = "subtest '$sub_name' of '$name'";
145
146         {
147                 local $Test::Builder::Level = $Test::Builder::Level + 1;
148
149                 cmp_field($result, $expect, "ok", $desc);
150
151                 cmp_field($result, $expect, "actual_ok", $desc);
152
153                 cmp_field($result, $expect, "type", $desc);
154
155                 cmp_field($result, $expect, "reason", $desc);
156
157                 cmp_field($result, $expect, "name", $desc);
158         }
159
160         # if we got no depth then default to 1
161         my $depth = 1;
162         if (exists $expect->{depth})
163         {
164                 $depth = $expect->{depth};
165         }
166
167         # if depth was explicitly undef then don't test it
168         if (defined $depth)
169         {
170                 $Test->is_eq($result->{depth}, $depth, "checking depth") ||
171                         $Test->diag('You need to change $Test::Builder::Level');
172         }
173
174         if (defined(my $exp = $expect->{diag}))
175         {
176
177         my $got = '';
178         if (ref $exp eq 'Regexp') {
179
180             if (not $Test->like($result->{diag}, $exp,
181                 "subtest '$sub_name' of '$name' compare diag"))
182             {
183                 $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             $exp .= "\n" if (length($exp) and $exp !~ /\n$/);
191
192             if (not $Test->ok($result->{diag} eq $exp,
193                         "subtest '$sub_name' of '$name' compare diag"))
194             {
195                 $got = $result->{diag};
196             }
197         }
198
199         if ($got) {
200                 my $glen = length($got);
201                 my $elen = length($exp);
202                 for ($got, $exp)
203                 {
204                         my @lines = split("\n", $_);
205                         $_ = join("\n", map {
206                                 if ($want_space)
207                                 {
208                                         $_ = $colour.escape($_).$reset;
209                                 }
210                                 else
211                                 {
212                                         "'$colour$_$reset'"
213                                 }
214                         } @lines);
215                 }
216
217                 $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         my $str = shift;
230         my $res = '';
231         for my $char (split("", $str))
232         {
233                 my $c = ord($char);
234                 if(($c>32 and $c<125) or $c == 10)
235                 {
236                         $res .= $char;
237                 }
238                 else
239                 {
240                         $res .= sprintf('\x{%x}', $c)
241                 }
242         }
243         return $res;
244 }
245
246 sub cmp_results
247 {
248         my ($results, $expects, $name) = @_;
249
250         $Test->is_num(scalar @$results, scalar @$expects, "Test '$name' result count");
251
252         for (my $i = 0; $i < @$expects; $i++)
253         {
254                 my $expect = $expects->[$i];
255                 my $result = $results->[$i];
256
257                 local $Test::Builder::Level = $Test::Builder::Level + 1;
258                 cmp_result($result, $expect, $name);
259         }
260 }
261
262 ######## nicked from Test::More
263 sub plan {
264         my(@plan) = @_;
265
266         my $caller = caller;
267
268         $Test->exported_to($caller);
269
270         my @imports = ();
271         foreach my $idx (0..$#plan) {
272                 if( $plan[$idx] eq 'import' ) {
273                         my($tag, $imports) = splice @plan, $idx, 2;
274                         @imports = @$imports;
275                         last;
276                 }
277         }
278
279         $Test->plan(@plan);
280
281         __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
282 }
283
284 sub import {
285         my($class) = shift;
286                 {
287                         no warnings 'redefine';
288                         *Test::Builder::new = \&new_new;
289                 }
290         goto &plan;
291 }
292
293 sub _export_to_level
294 {
295         my $pkg = shift;
296         my $level = shift;
297         (undef) = shift;        # redundant arg
298         my $callpkg = caller($level);
299         $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 it's 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