lib/Test/Builder/Tester.pm

   1 package Test::Builder::Tester;
   2
   3 use strict;
   4 use vars qw(@EXPORT $VERSION @ISA);
   5 $VERSION = "1.07";
   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::Builder::Tester::Tie", "STDOUT";
 106 my $err = tie *$error_handle,  "Test::Builder::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 Functions
 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 function 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 functions 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 C<<Test::Builder->no_ending>> turning off the ending tests.
 446 This is needed as otherwise it will trip out because we've run more
 447 tests than we strictly should have and it'll register any failures we
 448 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::Builder::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->{wanted}}, 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(?!\n)/ ) {
 510         $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E 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->{wanted}};
 528     my $got = $self->{got};
 529     foreach my $check (@checks) {
 530         $check = "\Q$check\E" unless ($check =~ s,^/(.*)/$,$1, or 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 = (
 596               type   => $self->{type},
 597               got    => '',
 598               wanted => [],
 599              );
 600 }
 601
 602
 603 sub got
 604 {
 605     my $self = shift;
 606     return $self->{got};
 607 }
 608
 609 sub wanted
 610 {
 611     my $self = shift;
 612     return $self->{wanted};
 613 }
 614
 615 sub type
 616 {
 617     my $self = shift;
 618     return $self->{type};
 619 }
 620
 621 ###
 622 # tie interface
 623 ###
 624
 625 sub PRINT  {
 626     my $self = shift;
 627     $self->{got} .= join '', @_;
 628 }
 629
 630 sub TIEHANDLE {
 631     my($class, $type) = @_;
 632
 633     my $self = bless {
 634                    type => $type
 635                }, $class;
 636
 637     $self->reset;
 638
 639     return $self;
 640 }
 641
 642 sub READ {}
 643 sub READLINE {}
 644 sub GETC {}
 645 sub FILENO {}
 646
 647 1;