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