lib/Test/Builder/Tester.pm

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