ext/Test-Simple/lib/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 # _export_to_level and import stolen directly from Test::More.  I am
  63 # the king of cargo cult programming ;-)
  64
  65 # 5.004's Exporter doesn't have export_to_level.
  66 sub _export_to_level {
  67     my $pkg   = shift;
  68     my $level = shift;
  69     (undef) = shift;    # XXX redundant arg
  70     my $callpkg = caller($level);
  71     $pkg->export( $callpkg, @_ );
  72 }
  73
  74 sub import {
  75     my $class = shift;
  76     my(@plan) = @_;
  77
  78     my $caller = caller;
  79
  80     $t->exported_to($caller);
  81     $t->plan(@plan);
  82
  83     my @imports = ();
  84     foreach my $idx ( 0 .. $#plan ) {
  85         if( $plan[$idx] eq 'import' ) {
  86             @imports = @{ $plan[ $idx + 1 ] };
  87             last;
  88         }
  89     }
  90
  91     __PACKAGE__->_export_to_level( 1, __PACKAGE__, @imports );
  92 }
  93
  94 ###
  95 # set up file handles
  96 ###
  97
  98 # create some private file handles
  99 my $output_handle = gensym;
 100 my $error_handle  = gensym;
 101
 102 # and tie them to this package
 103 my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT";
 104 my $err = tie *$error_handle,  "Test::Builder::Tester::Tie", "STDERR";
 105
 106 ####
 107 # exported functions
 108 ####
 109
 110 # for remembering that we're testing and where we're testing at
 111 my $testing = 0;
 112 my $testing_num;
 113
 114 # remembering where the file handles were originally connected
 115 my $original_output_handle;
 116 my $original_failure_handle;
 117 my $original_todo_handle;
 118
 119 my $original_test_number;
 120 my $original_harness_state;
 121
 122 my $original_harness_env;
 123
 124 # function that starts testing and redirects the filehandles for now
 125 sub _start_testing {
 126     # even if we're running under Test::Harness pretend we're not
 127     # for now.  This needed so Test::Builder doesn't add extra spaces
 128     $original_harness_env = $ENV{HARNESS_ACTIVE} || 0;
 129     $ENV{HARNESS_ACTIVE} = 0;
 130
 131     # remember what the handles were set to
 132     $original_output_handle  = $t->output();
 133     $original_failure_handle = $t->failure_output();
 134     $original_todo_handle    = $t->todo_output();
 135
 136     # switch out to our own handles
 137     $t->output($output_handle);
 138     $t->failure_output($error_handle);
 139     $t->todo_output($error_handle);
 140
 141     # clear the expected list
 142     $out->reset();
 143     $err->reset();
 144
 145     # remeber that we're testing
 146     $testing     = 1;
 147     $testing_num = $t->current_test;
 148     $t->current_test(0);
 149
 150     # look, we shouldn't do the ending stuff
 151     $t->no_ending(1);
 152 }
 153
 154 =head2 Functions
 155
 156 These are the six methods that are exported as default.
 157
 158 =over 4
 159
 160 =item test_out
 161
 162 =item test_err
 163
 164 Procedures for predeclaring the output that your test suite is
 165 expected to produce until C<test_test> is called.  These procedures
 166 automatically assume that each line terminates with "\n".  So
 167
 168    test_out("ok 1","ok 2");
 169
 170 is the same as
 171
 172    test_out("ok 1\nok 2");
 173
 174 which is even the same as
 175
 176    test_out("ok 1");
 177    test_out("ok 2");
 178
 179 Once C<test_out> or C<test_err> (or C<test_fail> or C<test_diag>) have
 180 been called once all further output from B<Test::Builder> will be
 181 captured by B<Test::Builder::Tester>.  This means that your will not
 182 be able perform further tests to the normal output in the normal way
 183 until you call C<test_test> (well, unless you manually meddle with the
 184 output filehandles)
 185
 186 =cut
 187
 188 sub test_out {
 189     # do we need to do any setup?
 190     _start_testing() unless $testing;
 191
 192     $out->expect(@_);
 193 }
 194
 195 sub test_err {
 196     # do we need to do any setup?
 197     _start_testing() unless $testing;
 198
 199     $err->expect(@_);
 200 }
 201
 202 =item test_fail
 203
 204 Because the standard failure message that B<Test::Builder> produces
 205 whenever a test fails will be a common occurrence in your test error
 206 output, and because has changed between Test::Builder versions, rather
 207 than forcing you to call C<test_err> with the string all the time like
 208 so
 209
 210     test_err("# Failed test ($0 at line ".line_num(+1).")");
 211
 212 C<test_fail> exists as a convenience function that can be called
 213 instead.  It takes one argument, the offset from the current line that
 214 the line that causes the fail is on.
 215
 216     test_fail(+1);
 217
 218 This means that the example in the synopsis could be rewritten
 219 more simply as:
 220
 221    test_out("not ok 1 - foo");
 222    test_fail(+1);
 223    fail("foo");
 224    test_test("fail works");
 225
 226 =cut
 227
 228 sub test_fail {
 229     # do we need to do any setup?
 230     _start_testing() unless $testing;
 231
 232     # work out what line we should be on
 233     my( $package, $filename, $line ) = caller;
 234     $line = $line + ( shift() || 0 );    # prevent warnings
 235
 236     # expect that on stderr
 237     $err->expect("#     Failed test ($0 at line $line)");
 238 }
 239
 240 =item test_diag
 241
 242 As most of the remaining expected output to the error stream will be
 243 created by Test::Builder's C<diag> function, B<Test::Builder::Tester>
 244 provides a convience function C<test_diag> that you can use instead of
 245 C<test_err>.
 246
 247 The C<test_diag> function prepends comment hashes and spacing to the
 248 start and newlines to the end of the expected output passed to it and
 249 adds it to the list of expected error output.  So, instead of writing
 250
 251    test_err("# Couldn't open file");
 252
 253 you can write
 254
 255    test_diag("Couldn't open file");
 256
 257 Remember that B<Test::Builder>'s diag function will not add newlines to
 258 the end of output and test_diag will. So to check
 259
 260    Test::Builder->new->diag("foo\n","bar\n");
 261
 262 You would do
 263
 264   test_diag("foo","bar")
 265
 266 without the newlines.
 267
 268 =cut
 269
 270 sub test_diag {
 271     # do we need to do any setup?
 272     _start_testing() unless $testing;
 273
 274     # expect the same thing, but prepended with "#     "
 275     local $_;
 276     $err->expect( map { "# $_" } @_ );
 277 }
 278
 279 =item test_test
 280
 281 Actually performs the output check testing the tests, comparing the
 282 data (with C<eq>) that we have captured from B<Test::Builder> against
 283 that that was declared with C<test_out> and C<test_err>.
 284
 285 This takes name/value pairs that effect how the test is run.
 286
 287 =over
 288
 289 =item title (synonym 'name', 'label')
 290
 291 The name of the test that will be displayed after the C<ok> or C<not
 292 ok>.
 293
 294 =item skip_out
 295
 296 Setting this to a true value will cause the test to ignore if the
 297 output sent by the test to the output stream does not match that
 298 declared with C<test_out>.
 299
 300 =item skip_err
 301
 302 Setting this to a true value will cause the test to ignore if the
 303 output sent by the test to the error stream does not match that
 304 declared with C<test_err>.
 305
 306 =back
 307
 308 As a convience, if only one argument is passed then this argument
 309 is assumed to be the name of the test (as in the above examples.)
 310
 311 Once C<test_test> has been run test output will be redirected back to
 312 the original filehandles that B<Test::Builder> was connected to
 313 (probably STDOUT and STDERR,) meaning any further tests you run
 314 will function normally and cause success/errors for B<Test::Harness>.
 315
 316 =cut
 317
 318 sub test_test {
 319     # decode the arguements 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     # okay, reconnect the test suite back to the saved handles
 337     $t->output($original_output_handle);
 338     $t->failure_output($original_failure_handle);
 339     $t->todo_output($original_todo_handle);
 340
 341     # restore the test no, etc, back to the original point
 342     $t->current_test($testing_num);
 343     $testing = 0;
 344
 345     # re-enable the original setting of the harness
 346     $ENV{HARNESS_ACTIVE} = $original_harness_env;
 347
 348     # check the output we've stashed
 349     unless( $t->ok( ( $args{skip_out} || $out->check ) &&
 350                     ( $args{skip_err} || $err->check ), $mess )
 351     )
 352     {
 353         # print out the diagnostic information about why this
 354         # test failed
 355
 356         local $_;
 357
 358         $t->diag( map { "$_\n" } $out->complaint )
 359           unless $args{skip_out} || $out->check;
 360
 361         $t->diag( map { "$_\n" } $err->complaint )
 362           unless $args{skip_err} || $err->check;
 363     }
 364 }
 365
 366 =item line_num
 367
 368 A utility function that returns the line number that the function was
 369 called on.  You can pass it an offset which will be added to the
 370 result.  This is very useful for working out the correct text of
 371 diagnostic functions that contain line numbers.
 372
 373 Essentially this is the same as the C<__LINE__> macro, but the
 374 C<line_num(+3)> idiom is arguably nicer.
 375
 376 =cut
 377
 378 sub line_num {
 379     my( $package, $filename, $line ) = caller;
 380     return $line + ( shift() || 0 );    # prevent warnings
 381 }
 382
 383 =back
 384
 385 In addition to the six exported functions there there exists one
 386 function that can only be accessed with a fully qualified function
 387 call.
 388
 389 =over 4
 390
 391 =item color
 392
 393 When C<test_test> is called and the output that your tests generate
 394 does not match that which you declared, C<test_test> will print out
 395 debug information showing the two conflicting versions.  As this
 396 output itself is debug information it can be confusing which part of
 397 the output is from C<test_test> and which was the original output from
 398 your original tests.  Also, it may be hard to spot things like
 399 extraneous whitespace at the end of lines that may cause your test to
 400 fail even though the output looks similar.
 401
 402 To assist you, if you have the B<Term::ANSIColor> module installed
 403 (which you should do by default from perl 5.005 onwards), C<test_test>
 404 can colour the background of the debug information to disambiguate the
 405 different types of output. The debug output will have it's background
 406 coloured green and red.  The green part represents the text which is
 407 the same between the executed and actual output, the red shows which
 408 part differs.
 409
 410 The C<color> function determines if colouring should occur or not.
 411 Passing it a true or false value will enable or disable colouring
 412 respectively, and the function called with no argument will return the
 413 current setting.
 414
 415 To enable colouring from the command line, you can use the
 416 B<Text::Builder::Tester::Color> module like so:
 417
 418    perl -Mlib=Text::Builder::Tester::Color test.t
 419
 420 Or by including the B<Test::Builder::Tester::Color> module directly in
 421 the PERL5LIB.
 422
 423 =cut
 424
 425 my $color;
 426
 427 sub color {
 428     $color = shift if @_;
 429     $color;
 430 }
 431
 432 =back
 433
 434 =head1 BUGS
 435
 436 Calls C<<Test::Builder->no_ending>> turning off the ending tests.
 437 This is needed as otherwise it will trip out because we've run more
 438 tests than we strictly should have and it'll register any failures we
 439 had that we were testing for as real failures.
 440
 441 The color function doesn't work unless B<Term::ANSIColor> is installed
 442 and is compatible with your terminal.
 443
 444 Bugs (and requests for new features) can be reported to the author
 445 though the CPAN RT system:
 446 L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Builder-Tester>
 447
 448 =head1 AUTHOR
 449
 450 Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
 451
 452 Some code taken from B<Test::More> and B<Test::Catch>, written by by
 453 Michael G Schwern E<lt>schwern@pobox.comE<gt>.  Hence, those parts
 454 Copyright Micheal G Schwern 2001.  Used and distributed with
 455 permission.
 456
 457 This program is free software; you can redistribute it
 458 and/or modify it under the same terms as Perl itself.
 459
 460 =head1 NOTES
 461
 462 This code has been tested explicitly on the following versions
 463 of perl: 5.7.3, 5.6.1, 5.6.0, 5.005_03, 5.004_05 and 5.004.
 464
 465 Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<gt> for letting
 466 me use his testing system to try this module out on.
 467
 468 =head1 SEE ALSO
 469
 470 L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>.
 471
 472 =cut
 473
 474 1;
 475
 476 ####################################################################
 477 # Helper class that is used to remember expected and received data
 478
 479 package Test::Builder::Tester::Tie;
 480
 481 ##
 482 # add line(s) to be expected
 483
 484 sub expect {
 485     my $self = shift;
 486
 487     my @checks = @_;
 488     foreach my $check (@checks) {
 489         $check = $self->_translate_Failed_check($check);
 490         push @{ $self->{wanted} }, ref $check ? $check : "$check\n";
 491     }
 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 "\n", @{ $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;