local-lib5/lib/perl5/Test/Builder/Tester.pm

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