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

   1 package Test::Builder::Tester;
   2
   3 use strict;
   4 our $VERSION = '1.302056';
   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 Test::Builder::Tester does not handle plans well. It has never done anything
 440 special with plans. This means that plans from outside Test::Builder::Tester
 441 will effect Test::Builder::Tester, worse plans when using Test::Builder::Tester
 442 will effect overall testing. At this point there are no plans to fix this bug
 443 as people have come to depend on it, and Test::Builder::Tester is now
 444 discouraged in favor of C<Test2::API::intercept()>. See
 445 L<https://github.com/Test-More/test-more/issues/667>
 446
 447 Calls C<< Test::Builder->no_ending >> turning off the ending tests.
 448 This is needed as otherwise it will trip out because we've run more
 449 tests than we strictly should have and it'll register any failures we
 450 had that we were testing for as real failures.
 451
 452 The color function doesn't work unless L<Term::ANSIColor> is
 453 compatible with your terminal.
 454
 455 Bugs (and requests for new features) can be reported to the author
 456 though the CPAN RT system:
 457 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Builder-Tester>
 458
 459 =head1 AUTHOR
 460
 461 Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
 462
 463 Some code taken from L<Test::More> and L<Test::Catch>, written by
 464 Michael G Schwern E<lt>schwern@pobox.comE<gt>.  Hence, those parts
 465 Copyright Micheal G Schwern 2001.  Used and distributed with
 466 permission.
 467
 468 This program is free software; you can redistribute it
 469 and/or modify it under the same terms as Perl itself.
 470
 471 =head1 MAINTAINERS
 472
 473 =over 4
 474
 475 =item Chad Granum E<lt>exodist@cpan.orgE<gt>
 476
 477 =back
 478
 479 =head1 NOTES
 480
 481 Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting
 482 me use his testing system to try this module out on.
 483
 484 =head1 SEE ALSO
 485
 486 L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>.
 487
 488 =cut
 489
 490 1;
 491
 492 ####################################################################
 493 # Helper class that is used to remember expected and received data
 494
 495 package Test::Builder::Tester::Tie;
 496
 497 ##
 498 # add line(s) to be expected
 499
 500 sub expect {
 501     my $self = shift;
 502
 503     my @checks = @_;
 504     foreach my $check (@checks) {
 505         $check = $self->_account_for_subtest($check);
 506         $check = $self->_translate_Failed_check($check);
 507         push @{ $self->{wanted} }, ref $check ? $check : "$check\n";
 508     }
 509 }
 510
 511 sub _account_for_subtest {
 512     my( $self, $check ) = @_;
 513
 514     my $hub = $t->{Stack}->top;
 515     my $nesting = $hub->isa('Test2::Hub::Subtest') ? $hub->nested : 0;
 516     return ref($check) ? $check : ('    ' x $nesting) . $check;
 517 }
 518
 519 sub _translate_Failed_check {
 520     my( $self, $check ) = @_;
 521
 522     if( $check =~ /\A(.*)#     (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) {
 523         $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/";
 524     }
 525
 526     return $check;
 527 }
 528
 529 ##
 530 # return true iff the expected data matches the got data
 531
 532 sub check {
 533     my $self = shift;
 534
 535     # turn off warnings as these might be undef
 536     local $^W = 0;
 537
 538     my @checks = @{ $self->{wanted} };
 539     my $got    = $self->{got};
 540     foreach my $check (@checks) {
 541         $check = "\Q$check\E" unless( $check =~ s,^/(.*)/$,$1, or ref $check );
 542         return 0 unless $got =~ s/^$check//;
 543     }
 544
 545     return length $got == 0;
 546 }
 547
 548 ##
 549 # a complaint message about the inputs not matching (to be
 550 # used for debugging messages)
 551
 552 sub complaint {
 553     my $self   = shift;
 554     my $type   = $self->type;
 555     my $got    = $self->got;
 556     my $wanted = join '', @{ $self->wanted };
 557
 558     # are we running in colour mode?
 559     if(Test::Builder::Tester::color) {
 560         # get color
 561         eval { require Term::ANSIColor };
 562         unless($@) {
 563             # colours
 564
 565             my $green = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_green");
 566             my $red   = Term::ANSIColor::color("black") . Term::ANSIColor::color("on_red");
 567             my $reset = Term::ANSIColor::color("reset");
 568
 569             # work out where the two strings start to differ
 570             my $char = 0;
 571             $char++ while substr( $got, $char, 1 ) eq substr( $wanted, $char, 1 );
 572
 573             # get the start string and the two end strings
 574             my $start = $green . substr( $wanted, 0, $char );
 575             my $gotend    = $red . substr( $got,    $char ) . $reset;
 576             my $wantedend = $red . substr( $wanted, $char ) . $reset;
 577
 578             # make the start turn green on and off
 579             $start =~ s/\n/$reset\n$green/g;
 580
 581             # make the ends turn red on and off
 582             $gotend    =~ s/\n/$reset\n$red/g;
 583             $wantedend =~ s/\n/$reset\n$red/g;
 584
 585             # rebuild the strings
 586             $got    = $start . $gotend;
 587             $wanted = $start . $wantedend;
 588         }
 589     }
 590
 591     my @got = split "\n", $got;
 592     my @wanted = split "\n", $wanted;
 593
 594     $got = "";
 595     $wanted = "";
 596
 597     while (@got || @wanted) {
 598         my $g = shift @got    || "";
 599         my $w = shift @wanted || "";
 600         if ($g ne $w) {
 601             if($g =~ s/(\s+)$/    |> /g) {
 602                 $g .= ($_ eq ' ' ? '_' : '\t') for split '', $1;
 603             }
 604             if($w =~ s/(\s+)$/    |> /g) {
 605                 $w .= ($_ eq ' ' ? '_' : '\t') for split '', $1;
 606             }
 607             $g = "> $g";
 608             $w = "> $w";
 609         }
 610         else {
 611             $g = "  $g";
 612             $w = "  $w";
 613         }
 614         $got = $got ? "$got\n$g" : $g;
 615         $wanted = $wanted ? "$wanted\n$w" : $w;
 616     }
 617
 618     return "$type is:\n" . "$got\nnot:\n$wanted\nas expected";
 619 }
 620
 621 ##
 622 # forget all expected and got data
 623
 624 sub reset {
 625     my $self = shift;
 626     %$self = (
 627         type   => $self->{type},
 628         got    => '',
 629         wanted => [],
 630     );
 631 }
 632
 633 sub got {
 634     my $self = shift;
 635     return $self->{got};
 636 }
 637
 638 sub wanted {
 639     my $self = shift;
 640     return $self->{wanted};
 641 }
 642
 643 sub type {
 644     my $self = shift;
 645     return $self->{type};
 646 }
 647
 648 ###
 649 # tie interface
 650 ###
 651
 652 sub PRINT {
 653     my $self = shift;
 654     $self->{got} .= join '', @_;
 655 }
 656
 657 sub TIEHANDLE {
 658     my( $class, $type ) = @_;
 659
 660     my $self = bless { type => $type }, $class;
 661
 662     $self->reset;
 663
 664     return $self;
 665 }
 666
 667 sub READ     { }
 668 sub READLINE { }
 669 sub GETC     { }
 670 sub FILENO   { }
 671
 672 1;