SecurityTests/regressions/inc/Test/Builder/Tester.pm

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