[Summary view] [Print] [Text view]

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