lib/Test/Builder/Tester.pm

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