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

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