cpan/Test-Simple/lib/Test/Builder/Tester.pm

   1 package Test::Builder::Tester;
   2
   3 use strict;
   4 our $VERSION = "1.24";
   5
   6 use Test::Builder 0.98;
   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 L<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 L<Test::Builder> to stdout and stderr.
  34
  35 You then can run the test(s) from your test suite that call
  36 L<Test::Builder>.  At this point the output of L<Test::Builder> is
  37 safely captured by L<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 L<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 my $original_is_passing;
 102
 103 # remembering where the file handles were originally connected
 104 my $original_output_handle;
 105 my $original_failure_handle;
 106 my $original_todo_handle;
 107
 108 my $original_harness_env;
 109
 110 # function that starts testing and redirects the filehandles for now
 111 sub _start_testing {
 112     # even if we're running under Test::Harness pretend we're not
 113     # for now.  This needed so Test::Builder doesn't add extra spaces
 114     $original_harness_env = $ENV{HARNESS_ACTIVE} || 0;
 115     $ENV{HARNESS_ACTIVE} = 0;
 116
 117     # remember what the handles were set to
 118     $original_output_handle  = $t->output();
 119     $original_failure_handle = $t->failure_output();
 120     $original_todo_handle    = $t->todo_output();
 121
 122     # switch out to our own handles
 123     $t->output($output_handle);
 124     $t->failure_output($error_handle);
 125     $t->todo_output($output_handle);
 126
 127     # clear the expected list
 128     $out->reset();
 129     $err->reset();
 130
 131     # remember that we're testing
 132     $testing     = 1;
 133     $testing_num = $t->current_test;
 134     $t->current_test(0);
 135     $original_is_passing  = $t->is_passing;
 136     $t->is_passing(1);
 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, all further output from L<Test::Builder> will be
 169 captured by L<Test::Builder::Tester>.  This means that you 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 L<Test::Builder> produces
 193 whenever a test fails will be a common occurrence in your test error
 194 output, and because it 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 ($filename 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 L<Test::Builder>'s C<diag> function, L<Test::Builder::Tester>
 232 provides a convenience 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 L<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 L<Test::Builder> against
 271 what 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 convenience, 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 L<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 L<Test::Harness>.
 303
 304 =cut
 305
 306 sub test_test {
 307     # decode the arguments 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     $t->is_passing($original_is_passing);
 333
 334     # re-enable the original setting of the harness
 335     $ENV{HARNESS_ACTIVE} = $original_harness_env;
 336
 337     # check the output we've stashed
 338     unless( $t->ok( ( $args{skip_out} || $out->check ) &&
 339                     ( $args{skip_err} || $err->check ), $mess )
 340     )
 341     {
 342         # print out the diagnostic information about why this
 343         # test failed
 344
 345         local $_;
 346
 347         $t->diag( map { "$_\n" } $out->complaint )
 348           unless $args{skip_out} || $out->check;
 349
 350         $t->diag( map { "$_\n" } $err->complaint )
 351           unless $args{skip_err} || $err->check;
 352     }
 353 }
 354
 355 =item line_num
 356
 357 A utility function that returns the line number that the function was
 358 called on.  You can pass it an offset which will be added to the
 359 result.  This is very useful for working out the correct text of
 360 diagnostic functions that contain line numbers.
 361
 362 Essentially this is the same as the C<__LINE__> macro, but the
 363 C<line_num(+3)> idiom is arguably nicer.
 364
 365 =cut
 366
 367 sub line_num {
 368     my( $package, $filename, $line ) = caller;
 369     return $line + ( shift() || 0 );    # prevent warnings
 370 }
 371
 372 =back
 373
 374 In addition to the six exported functions there exists one
 375 function that can only be accessed with a fully qualified function
 376 call.
 377
 378 =over 4
 379
 380 =item color
 381
 382 When C<test_test> is called and the output that your tests generate
 383 does not match that which you declared, C<test_test> will print out
 384 debug information showing the two conflicting versions.  As this
 385 output itself is debug information it can be confusing which part of
 386 the output is from C<test_test> and which was the original output from
 387 your original tests.  Also, it may be hard to spot things like
 388 extraneous whitespace at the end of lines that may cause your test to
 389 fail even though the output looks similar.
 390
 391 To assist you C<test_test> can colour the background of the debug
 392 information to disambiguate the different types of output. The debug
 393 output will have its background coloured green and red.  The green
 394 part represents the text which is the same between the executed and
 395 actual output, the red shows which part differs.
 396
 397 The C<color> function determines if colouring should occur or not.
 398 Passing it a true or false value will enable or disable colouring
 399 respectively, and the function called with no argument will return the
 400 current setting.
 401
 402 To enable colouring from the command line, you can use the
 403 L<Text::Builder::Tester::Color> module like so:
 404
 405    perl -Mlib=Text::Builder::Tester::Color test.t
 406
 407 Or by including the L<Test::Builder::Tester::Color> module directly in
 408 the PERL5LIB.
 409
 410 =cut
 411
 412 my $color;
 413
 414 sub color {
 415     $color = shift if @_;
 416     $color;
 417 }
 418
 419 =back
 420
 421 =head1 BUGS
 422
 423 Calls C<< Test::Builder->no_ending >> turning off the ending tests.
 424 This is needed as otherwise it will trip out because we've run more
 425 tests than we strictly should have and it'll register any failures we
 426 had that we were testing for as real failures.
 427
 428 The color function doesn't work unless L<Term::ANSIColor> is
 429 compatible with your terminal.
 430
 431 Bugs (and requests for new features) can be reported to the author
 432 though the CPAN RT system:
 433 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Builder-Tester>
 434
 435 =head1 AUTHOR
 436
 437 Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
 438
 439 Some code taken from L<Test::More> and L<Test::Catch>, written by
 440 Michael G Schwern E<lt>schwern@pobox.comE<gt>.  Hence, those parts
 441 Copyright Micheal G Schwern 2001.  Used and distributed with
 442 permission.
 443
 444 This program is free software; you can redistribute it
 445 and/or modify it under the same terms as Perl itself.
 446
 447 =head1 MAINTAINERS
 448
 449 =over 4
 450
 451 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
 452
 453 =back
 454
 455 =head1 NOTES
 456
 457 Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting
 458 me use his testing system to try this module out on.
 459
 460 =head1 SEE ALSO
 461
 462 L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>.
 463
 464 =cut
 465
 466 1;
 467
 468 ####################################################################
 469 # Helper class that is used to remember expected and received data
 470
 471 package Test::Builder::Tester::Tie;
 472
 473 ##
 474 # add line(s) to be expected
 475
 476 sub expect {
 477     my $self = shift;
 478
 479     my @checks = @_;
 480     foreach my $check (@checks) {
 481         $check = $self->_account_for_subtest($check);
 482         $check = $self->_translate_Failed_check($check);
 483         push @{ $self->{wanted} }, ref $check ? $check : "$check\n";
 484     }
 485 }
 486
 487 sub _account_for_subtest {
 488     my( $self, $check ) = @_;
 489
 490     # Since we ship with Test::Builder, calling a private method is safe...ish.
 491     return ref($check) ? $check : $t->_indent . $check;
 492 }
 493
 494 sub _translate_Failed_check {
 495     my( $self, $check ) = @_;
 496
 497     if( $check =~ /\A(.*)#     (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) {
 498         $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/";
 499     }
 500
 501     return $check;
 502 }
 503
 504 ##
 505 # return true iff the expected data matches the got data
 506
 507 sub check {
 508     my $self = shift;
 509
 510     # turn off warnings as these might be undef
 511     local $^W = 0;
 512
 513     my @checks = @{ $self->{wanted} };
 514     my $got    = $self->{got};
 515     foreach my $check (@checks) {
 516         $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check );
 517         return 0 unless $got =~ s/^$check//;
 518     }
 519
 520     return length $got == 0;
 521 }
 522
 523 ##
 524 # a complaint message about the inputs not matching (to be
 525 # used for debugging messages)
 526
 527 sub complaint {
 528     my $self   = shift;
 529     my $type   = $self->type;
 530     my $got    = $self->got;
 531     my $wanted = join '', @{ $self->wanted };
 532
 533     # are we running in colour mode?
 534     if(Test::Builder::Tester::color) {
 535         # get color
 536         eval { require Term::ANSIColor };
 537         unless($@) {
 538             # colours
 539
 540             my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green");
 541             my $red   = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_red");
 542             my $reset = Term::ANSIColor::color("reset");
 543
 544             # work out where the two strings start to differ
 545             my $char = 0;
 546             $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 );
 547
 548             # get the start string and the two end strings
 549             my $start = $green . substr( $wanted, 0, $char );
 550             my $gotend    = $red . substr( $got,    $char ) . $reset;
 551             my $wantedend = $red . substr( $wanted, $char ) . $reset;
 552
 553             # make the start turn green on and off
 554             $start =~ s/\n/$reset\n$green/g;
 555
 556             # make the ends turn red on and off
 557             $gotend    =~ s/\n/$reset\n$red/g;
 558             $wantedend =~ s/\n/$reset\n$red/g;
 559
 560             # rebuild the strings
 561             $got    = $start . $gotend;
 562             $wanted = $start . $wantedend;
 563         }
 564     }
 565
 566     return "$type is:\n" . "$got\nnot:\n$wanted\nas expected";
 567 }
 568
 569 ##
 570 # forget all expected and got data
 571
 572 sub reset {
 573     my $self = shift;
 574     %$self = (
 575         type   => $self->{type},
 576         got    => '',
 577         wanted => [],
 578     );
 579 }
 580
 581 sub got {
 582     my $self = shift;
 583     return $self->{got};
 584 }
 585
 586 sub wanted {
 587     my $self = shift;
 588     return $self->{wanted};
 589 }
 590
 591 sub type {
 592     my $self = shift;
 593     return $self->{type};
 594 }
 595
 596 ###
 597 # tie interface
 598 ###
 599
 600 sub PRINT {
 601     my $self = shift;
 602     $self->{got} .= join '', @_;
 603 }
 604
 605 sub TIEHANDLE {
 606     my( $class, $type ) = @_;
 607
 608     my $self = bless { type => $type }, $class;
 609
 610     $self->reset;
 611
 612     return $self;
 613 }
 614
 615 sub READ     { }
 616 sub READLINE { }
 617 sub GETC     { }
 618 sub FILENO   { }
 619
 620 1;