Commit | Line | Data |
---|---|---|
920dae64 AT |
1 | package Test::Builder::Tester; |
2 | ||
3 | use strict; | |
4 | use vars qw(@EXPORT $VERSION @ISA); | |
5 | $VERSION = "1.02"; | |
6 | ||
7 | use Test::Builder; | |
8 | use Symbol; | |
9 | use Carp; | |
10 | ||
11 | =head1 NAME | |
12 | ||
13 | Test::Builder::Tester - test testsuites that have been built with | |
14 | Test::Builder | |
15 | ||
16 | =head1 SYNOPSIS | |
17 | ||
18 | use Test::Builder::Tester tests => 1; | |
19 | use Test::More; | |
20 | ||
21 | test_out("not ok 1 - foo"); | |
22 | test_fail(+1); | |
23 | fail("foo"); | |
24 | test_test("fail works"); | |
25 | ||
26 | =head1 DESCRIPTION | |
27 | ||
28 | A module that helps you test testing modules that are built with | |
29 | B<Test::Builder>. | |
30 | ||
31 | The testing system is designed to be used by performing a three step | |
32 | process for each test you wish to test. This process starts with using | |
33 | C<test_out> and C<test_err> in advance to declare what the testsuite you | |
34 | are testing will output with B<Test::Builder> to stdout and stderr. | |
35 | ||
36 | You then can run the test(s) from your test suite that call | |
37 | B<Test::Builder>. At this point the output of B<Test::Builder> is | |
38 | safely captured by B<Test::Builder::Tester> rather than being | |
39 | interpreted as real test output. | |
40 | ||
41 | The final stage is to call C<test_test> that will simply compare what you | |
42 | predeclared to what B<Test::Builder> actually outputted, and report the | |
43 | results back with a "ok" or "not ok" (with debugging) to the normal | |
44 | output. | |
45 | ||
46 | =cut | |
47 | ||
48 | #### | |
49 | # set up testing | |
50 | #### | |
51 | ||
52 | my $t = Test::Builder->new; | |
53 | ||
54 | ### | |
55 | # make us an exporter | |
56 | ### | |
57 | ||
58 | use Exporter; | |
59 | @ISA = qw(Exporter); | |
60 | ||
61 | @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num); | |
62 | ||
63 | # _export_to_level and import stolen directly from Test::More. I am | |
64 | # the king of cargo cult programming ;-) | |
65 | ||
66 | # 5.004's Exporter doesn't have export_to_level. | |
67 | sub _export_to_level | |
68 | { | |
69 | my $pkg = shift; | |
70 | my $level = shift; | |
71 | (undef) = shift; # XXX redundant arg | |
72 | my $callpkg = caller($level); | |
73 | $pkg->export($callpkg, @_); | |
74 | } | |
75 | ||
76 | sub import { | |
77 | my $class = shift; | |
78 | my(@plan) = @_; | |
79 | ||
80 | my $caller = caller; | |
81 | ||
82 | $t->exported_to($caller); | |
83 | $t->plan(@plan); | |
84 | ||
85 | my @imports = (); | |
86 | foreach my $idx (0..$#plan) { | |
87 | if( $plan[$idx] eq 'import' ) { | |
88 | @imports = @{$plan[$idx+1]}; | |
89 | last; | |
90 | } | |
91 | } | |
92 | ||
93 | __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); | |
94 | } | |
95 | ||
96 | ### | |
97 | # set up file handles | |
98 | ### | |
99 | ||
100 | # create some private file handles | |
101 | my $output_handle = gensym; | |
102 | my $error_handle = gensym; | |
103 | ||
104 | # and tie them to this package | |
105 | my $out = tie *$output_handle, "Test::Tester::Tie", "STDOUT"; | |
106 | my $err = tie *$error_handle, "Test::Tester::Tie", "STDERR"; | |
107 | ||
108 | #### | |
109 | # exported functions | |
110 | #### | |
111 | ||
112 | # for remembering that we're testing and where we're testing at | |
113 | my $testing = 0; | |
114 | my $testing_num; | |
115 | ||
116 | # remembering where the file handles were originally connected | |
117 | my $original_output_handle; | |
118 | my $original_failure_handle; | |
119 | my $original_todo_handle; | |
120 | ||
121 | my $original_test_number; | |
122 | my $original_harness_state; | |
123 | ||
124 | my $original_harness_env; | |
125 | ||
126 | # function that starts testing and redirects the filehandles for now | |
127 | sub _start_testing | |
128 | { | |
129 | # even if we're running under Test::Harness pretend we're not | |
130 | # for now. This needed so Test::Builder doesn't add extra spaces | |
131 | $original_harness_env = $ENV{HARNESS_ACTIVE} || 0; | |
132 | $ENV{HARNESS_ACTIVE} = 0; | |
133 | ||
134 | # remember what the handles were set to | |
135 | $original_output_handle = $t->output(); | |
136 | $original_failure_handle = $t->failure_output(); | |
137 | $original_todo_handle = $t->todo_output(); | |
138 | ||
139 | # switch out to our own handles | |
140 | $t->output($output_handle); | |
141 | $t->failure_output($error_handle); | |
142 | $t->todo_output($error_handle); | |
143 | ||
144 | # clear the expected list | |
145 | $out->reset(); | |
146 | $err->reset(); | |
147 | ||
148 | # remeber that we're testing | |
149 | $testing = 1; | |
150 | $testing_num = $t->current_test; | |
151 | $t->current_test(0); | |
152 | ||
153 | # look, we shouldn't do the ending stuff | |
154 | $t->no_ending(1); | |
155 | } | |
156 | ||
157 | =head2 Methods | |
158 | ||
159 | These are the six methods that are exported as default. | |
160 | ||
161 | =over 4 | |
162 | ||
163 | =item test_out | |
164 | ||
165 | =item test_err | |
166 | ||
167 | Procedures for predeclaring the output that your test suite is | |
168 | expected to produce until C<test_test> is called. These procedures | |
169 | automatically assume that each line terminates with "\n". So | |
170 | ||
171 | test_out("ok 1","ok 2"); | |
172 | ||
173 | is the same as | |
174 | ||
175 | test_out("ok 1\nok 2"); | |
176 | ||
177 | which is even the same as | |
178 | ||
179 | test_out("ok 1"); | |
180 | test_out("ok 2"); | |
181 | ||
182 | Once C<test_out> or C<test_err> (or C<test_fail> or C<test_diag>) have | |
183 | been called once all further output from B<Test::Builder> will be | |
184 | captured by B<Test::Builder::Tester>. This means that your will not | |
185 | be able perform further tests to the normal output in the normal way | |
186 | until you call C<test_test> (well, unless you manually meddle with the | |
187 | output filehandles) | |
188 | ||
189 | =cut | |
190 | ||
191 | sub test_out(@) | |
192 | { | |
193 | # do we need to do any setup? | |
194 | _start_testing() unless $testing; | |
195 | ||
196 | $out->expect(@_) | |
197 | } | |
198 | ||
199 | sub test_err(@) | |
200 | { | |
201 | # do we need to do any setup? | |
202 | _start_testing() unless $testing; | |
203 | ||
204 | $err->expect(@_) | |
205 | } | |
206 | ||
207 | =item test_fail | |
208 | ||
209 | Because the standard failure message that B<Test::Builder> produces | |
210 | whenever a test fails will be a common occurrence in your test error | |
211 | output, and because has changed between Test::Builder versions, rather | |
212 | than forcing you to call C<test_err> with the string all the time like | |
213 | so | |
214 | ||
215 | test_err("# Failed test ($0 at line ".line_num(+1).")"); | |
216 | ||
217 | C<test_fail> exists as a convenience method that can be called | |
218 | instead. It takes one argument, the offset from the current line that | |
219 | the line that causes the fail is on. | |
220 | ||
221 | test_fail(+1); | |
222 | ||
223 | This means that the example in the synopsis could be rewritten | |
224 | more simply as: | |
225 | ||
226 | test_out("not ok 1 - foo"); | |
227 | test_fail(+1); | |
228 | fail("foo"); | |
229 | test_test("fail works"); | |
230 | ||
231 | =cut | |
232 | ||
233 | sub test_fail | |
234 | { | |
235 | # do we need to do any setup? | |
236 | _start_testing() unless $testing; | |
237 | ||
238 | # work out what line we should be on | |
239 | my ($package, $filename, $line) = caller; | |
240 | $line = $line + (shift() || 0); # prevent warnings | |
241 | ||
242 | # expect that on stderr | |
243 | $err->expect("# Failed test ($0 at line $line)"); | |
244 | } | |
245 | ||
246 | =item test_diag | |
247 | ||
248 | As most of the remaining expected output to the error stream will be | |
249 | created by Test::Builder's C<diag> function, B<Test::Builder::Tester> | |
250 | provides a convience function C<test_diag> that you can use instead of | |
251 | C<test_err>. | |
252 | ||
253 | The C<test_diag> function prepends comment hashes and spacing to the | |
254 | start and newlines to the end of the expected output passed to it and | |
255 | adds it to the list of expected error output. So, instead of writing | |
256 | ||
257 | test_err("# Couldn't open file"); | |
258 | ||
259 | you can write | |
260 | ||
261 | test_diag("Couldn't open file"); | |
262 | ||
263 | Remember that B<Test::Builder>'s diag function will not add newlines to | |
264 | the end of output and test_diag will. So to check | |
265 | ||
266 | Test::Builder->new->diag("foo\n","bar\n"); | |
267 | ||
268 | You would do | |
269 | ||
270 | test_diag("foo","bar") | |
271 | ||
272 | without the newlines. | |
273 | ||
274 | =cut | |
275 | ||
276 | sub test_diag | |
277 | { | |
278 | # do we need to do any setup? | |
279 | _start_testing() unless $testing; | |
280 | ||
281 | # expect the same thing, but prepended with "# " | |
282 | local $_; | |
283 | $err->expect(map {"# $_"} @_) | |
284 | } | |
285 | ||
286 | =item test_test | |
287 | ||
288 | Actually performs the output check testing the tests, comparing the | |
289 | data (with C<eq>) that we have captured from B<Test::Builder> against | |
290 | that that was declared with C<test_out> and C<test_err>. | |
291 | ||
292 | This takes name/value pairs that effect how the test is run. | |
293 | ||
294 | =over | |
295 | ||
296 | =item title (synonym 'name', 'label') | |
297 | ||
298 | The name of the test that will be displayed after the C<ok> or C<not | |
299 | ok>. | |
300 | ||
301 | =item skip_out | |
302 | ||
303 | Setting this to a true value will cause the test to ignore if the | |
304 | output sent by the test to the output stream does not match that | |
305 | declared with C<test_out>. | |
306 | ||
307 | =item skip_err | |
308 | ||
309 | Setting this to a true value will cause the test to ignore if the | |
310 | output sent by the test to the error stream does not match that | |
311 | declared with C<test_err>. | |
312 | ||
313 | =back | |
314 | ||
315 | As a convience, if only one argument is passed then this argument | |
316 | is assumed to be the name of the test (as in the above examples.) | |
317 | ||
318 | Once C<test_test> has been run test output will be redirected back to | |
319 | the original filehandles that B<Test::Builder> was connected to | |
320 | (probably STDOUT and STDERR,) meaning any further tests you run | |
321 | will function normally and cause success/errors for B<Test::Harness>. | |
322 | ||
323 | =cut | |
324 | ||
325 | sub test_test | |
326 | { | |
327 | # decode the arguements as described in the pod | |
328 | my $mess; | |
329 | my %args; | |
330 | if (@_ == 1) | |
331 | { $mess = shift } | |
332 | else | |
333 | { | |
334 | %args = @_; | |
335 | $mess = $args{name} if exists($args{name}); | |
336 | $mess = $args{title} if exists($args{title}); | |
337 | $mess = $args{label} if exists($args{label}); | |
338 | } | |
339 | ||
340 | # er, are we testing? | |
341 | croak "Not testing. You must declare output with a test function first." | |
342 | unless $testing; | |
343 | ||
344 | # okay, reconnect the test suite back to the saved handles | |
345 | $t->output($original_output_handle); | |
346 | $t->failure_output($original_failure_handle); | |
347 | $t->todo_output($original_todo_handle); | |
348 | ||
349 | # restore the test no, etc, back to the original point | |
350 | $t->current_test($testing_num); | |
351 | $testing = 0; | |
352 | ||
353 | # re-enable the original setting of the harness | |
354 | $ENV{HARNESS_ACTIVE} = $original_harness_env; | |
355 | ||
356 | # check the output we've stashed | |
357 | unless ($t->ok( ($args{skip_out} || $out->check) | |
358 | && ($args{skip_err} || $err->check), | |
359 | $mess)) | |
360 | { | |
361 | # print out the diagnostic information about why this | |
362 | # test failed | |
363 | ||
364 | local $_; | |
365 | ||
366 | $t->diag(map {"$_\n"} $out->complaint) | |
367 | unless $args{skip_out} || $out->check; | |
368 | ||
369 | $t->diag(map {"$_\n"} $err->complaint) | |
370 | unless $args{skip_err} || $err->check; | |
371 | } | |
372 | } | |
373 | ||
374 | =item line_num | |
375 | ||
376 | A utility function that returns the line number that the function was | |
377 | called on. You can pass it an offset which will be added to the | |
378 | result. This is very useful for working out the correct text of | |
379 | diagnostic methods that contain line numbers. | |
380 | ||
381 | Essentially this is the same as the C<__LINE__> macro, but the | |
382 | C<line_num(+3)> idiom is arguably nicer. | |
383 | ||
384 | =cut | |
385 | ||
386 | sub line_num | |
387 | { | |
388 | my ($package, $filename, $line) = caller; | |
389 | return $line + (shift() || 0); # prevent warnings | |
390 | } | |
391 | ||
392 | =back | |
393 | ||
394 | In addition to the six exported functions there there exists one | |
395 | function that can only be accessed with a fully qualified function | |
396 | call. | |
397 | ||
398 | =over 4 | |
399 | ||
400 | =item color | |
401 | ||
402 | When C<test_test> is called and the output that your tests generate | |
403 | does not match that which you declared, C<test_test> will print out | |
404 | debug information showing the two conflicting versions. As this | |
405 | output itself is debug information it can be confusing which part of | |
406 | the output is from C<test_test> and which was the original output from | |
407 | your original tests. Also, it may be hard to spot things like | |
408 | extraneous whitespace at the end of lines that may cause your test to | |
409 | fail even though the output looks similar. | |
410 | ||
411 | To assist you, if you have the B<Term::ANSIColor> module installed | |
412 | (which you should do by default from perl 5.005 onwards), C<test_test> | |
413 | can colour the background of the debug information to disambiguate the | |
414 | different types of output. The debug output will have it's background | |
415 | coloured green and red. The green part represents the text which is | |
416 | the same between the executed and actual output, the red shows which | |
417 | part differs. | |
418 | ||
419 | The C<color> function determines if colouring should occur or not. | |
420 | Passing it a true or false value will enable or disable colouring | |
421 | respectively, and the function called with no argument will return the | |
422 | current setting. | |
423 | ||
424 | To enable colouring from the command line, you can use the | |
425 | B<Text::Builder::Tester::Color> module like so: | |
426 | ||
427 | perl -Mlib=Text::Builder::Tester::Color test.t | |
428 | ||
429 | Or by including the B<Test::Builder::Tester::Color> module directly in | |
430 | the PERL5LIB. | |
431 | ||
432 | =cut | |
433 | ||
434 | my $color; | |
435 | sub color | |
436 | { | |
437 | $color = shift if @_; | |
438 | $color; | |
439 | } | |
440 | ||
441 | =back | |
442 | ||
443 | =head1 BUGS | |
444 | ||
445 | Calls B<Test::Builder>'s C<no_ending> method turning off the ending | |
446 | tests. This is needed as otherwise it will trip out because we've run | |
447 | more tests than we strictly should have and it'll register any | |
448 | failures we had that we were testing for as real failures. | |
449 | ||
450 | The color function doesn't work unless B<Term::ANSIColor> is installed | |
451 | and is compatible with your terminal. | |
452 | ||
453 | Bugs (and requests for new features) can be reported to the author | |
454 | though the CPAN RT system: | |
455 | L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Builder-Tester> | |
456 | ||
457 | =head1 AUTHOR | |
458 | ||
459 | Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004. | |
460 | ||
461 | Some code taken from B<Test::More> and B<Test::Catch>, written by by | |
462 | Michael G Schwern E<lt>schwern@pobox.comE<gt>. Hence, those parts | |
463 | Copyright Micheal G Schwern 2001. Used and distributed with | |
464 | permission. | |
465 | ||
466 | This program is free software; you can redistribute it | |
467 | and/or modify it under the same terms as Perl itself. | |
468 | ||
469 | =head1 NOTES | |
470 | ||
471 | This code has been tested explicitly on the following versions | |
472 | of perl: 5.7.3, 5.6.1, 5.6.0, 5.005_03, 5.004_05 and 5.004. | |
473 | ||
474 | Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting | |
475 | me use his testing system to try this module out on. | |
476 | ||
477 | =head1 SEE ALSO | |
478 | ||
479 | L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>. | |
480 | ||
481 | =cut | |
482 | ||
483 | 1; | |
484 | ||
485 | #################################################################### | |
486 | # Helper class that is used to remember expected and received data | |
487 | ||
488 | package Test::Tester::Tie; | |
489 | ||
490 | ## | |
491 | # add line(s) to be expected | |
492 | ||
493 | sub expect | |
494 | { | |
495 | my $self = shift; | |
496 | ||
497 | my @checks = @_; | |
498 | foreach my $check (@checks) { | |
499 | $check = $self->_translate_Failed_check($check); | |
500 | push @{$self->[2]}, ref $check ? $check : "$check\n"; | |
501 | } | |
502 | } | |
503 | ||
504 | ||
505 | sub _translate_Failed_check | |
506 | { | |
507 | my($self, $check) = @_; | |
508 | ||
509 | if( $check =~ /\A(.*)# (Failed .*test) \((.*?) at line (\d+)\)\z/ ) { | |
510 | $check = qr/\Q$1\E#\s+\Q$2\E.*?\n?.*?\Q$3\E at line \Q$4\E.*\n?/; | |
511 | } | |
512 | ||
513 | return $check; | |
514 | } | |
515 | ||
516 | ||
517 | ## | |
518 | # return true iff the expected data matches the got data | |
519 | ||
520 | sub check | |
521 | { | |
522 | my $self = shift; | |
523 | ||
524 | # turn off warnings as these might be undef | |
525 | local $^W = 0; | |
526 | ||
527 | my @checks = @{$self->[2]}; | |
528 | my $got = $self->[1]; | |
529 | foreach my $check (@checks) { | |
530 | $check = qr/^\Q$check\E/ unless ref $check; | |
531 | return 0 unless $got =~ s/^$check//; | |
532 | } | |
533 | ||
534 | return length $got == 0; | |
535 | } | |
536 | ||
537 | ## | |
538 | # a complaint message about the inputs not matching (to be | |
539 | # used for debugging messages) | |
540 | ||
541 | sub complaint | |
542 | { | |
543 | my $self = shift; | |
544 | my $type = $self->type; | |
545 | my $got = $self->got; | |
546 | my $wanted = join "\n", @{$self->wanted}; | |
547 | ||
548 | # are we running in colour mode? | |
549 | if (Test::Builder::Tester::color) | |
550 | { | |
551 | # get color | |
552 | eval "require Term::ANSIColor"; | |
553 | unless ($@) | |
554 | { | |
555 | # colours | |
556 | ||
557 | my $green = Term::ANSIColor::color("black"). | |
558 | Term::ANSIColor::color("on_green"); | |
559 | my $red = Term::ANSIColor::color("black"). | |
560 | Term::ANSIColor::color("on_red"); | |
561 | my $reset = Term::ANSIColor::color("reset"); | |
562 | ||
563 | # work out where the two strings start to differ | |
564 | my $char = 0; | |
565 | $char++ while substr($got, $char, 1) eq substr($wanted, $char, 1); | |
566 | ||
567 | # get the start string and the two end strings | |
568 | my $start = $green . substr($wanted, 0, $char); | |
569 | my $gotend = $red . substr($got , $char) . $reset; | |
570 | my $wantedend = $red . substr($wanted, $char) . $reset; | |
571 | ||
572 | # make the start turn green on and off | |
573 | $start =~ s/\n/$reset\n$green/g; | |
574 | ||
575 | # make the ends turn red on and off | |
576 | $gotend =~ s/\n/$reset\n$red/g; | |
577 | $wantedend =~ s/\n/$reset\n$red/g; | |
578 | ||
579 | # rebuild the strings | |
580 | $got = $start . $gotend; | |
581 | $wanted = $start . $wantedend; | |
582 | } | |
583 | } | |
584 | ||
585 | return "$type is:\n" . | |
586 | "$got\nnot:\n$wanted\nas expected" | |
587 | } | |
588 | ||
589 | ## | |
590 | # forget all expected and got data | |
591 | ||
592 | sub reset | |
593 | { | |
594 | my $self = shift; | |
595 | @$self = ($self->[0], '', []); | |
596 | } | |
597 | ||
598 | ||
599 | sub got | |
600 | { | |
601 | my $self = shift; | |
602 | return $self->[1]; | |
603 | } | |
604 | ||
605 | sub wanted | |
606 | { | |
607 | my $self = shift; | |
608 | return $self->[2]; | |
609 | } | |
610 | ||
611 | sub type | |
612 | { | |
613 | my $self = shift; | |
614 | return $self->[0]; | |
615 | } | |
616 | ||
617 | ### | |
618 | # tie interface | |
619 | ### | |
620 | ||
621 | sub PRINT { | |
622 | my $self = shift; | |
623 | $self->[1] .= join '', @_; | |
624 | } | |
625 | ||
626 | sub TIEHANDLE { | |
627 | my($class, $type) = @_; | |
628 | ||
629 | my $self = bless [$type], $class; | |
630 | $self->reset; | |
631 | ||
632 | return $self; | |
633 | } | |
634 | ||
635 | sub READ {} | |
636 | sub READLINE {} | |
637 | sub GETC {} | |
638 | sub FILENO {} | |
639 | ||
640 | 1; |