lib/Test/Leaner.pm

   1 package Test::Leaner;
   2
   3 use 5.006;
   4 use strict;
   5 use warnings;
   6
   7 =head1 NAME
   8
   9 Test::Leaner - A slimmer Test::More for when you favor performance over completeness.
  10
  11 =head1 VERSION
  12
  13 Version 0.02
  14
  15 =cut
  16
  17 our $VERSION = '0.02';
  18
  19 =head1 SYNOPSIS
  20
  21     use Test::Leaner tests => 10_000;
  22     for (1 .. 10_000) {
  23      ...
  24      is $one, 1, "checking situation $_";
  25     }
  26
  27
  28 =head1 DESCRIPTION
  29
  30 When profiling some L<Test::More>-based test script that contained about 10 000 unit tests, I realized that 60% of the time was spent in L<Test::Builder> itself, even though every single test actually involved a costly C<eval STRING>.
  31
  32 This module aims to be a partial replacement to L<Test::More> in those situations where you want to run a large number of simple tests.
  33 Its functions behave the same as their L<Test::More> counterparts, except for the following differences :
  34
  35 =over 4
  36
  37 =item *
  38
  39 Stringification isn't forced on the test operands.
  40 However, L</ok> honors C<'bool'> overloading, L</is> and L</is_deeply> honor C<'eq'> overloading (and just that one), L</isnt> honors C<'ne'> overloading, and L</cmp_ok> honors whichever overloading category corresponds to the specified operator.
  41
  42 =item *
  43
  44 L</pass>, L</fail>, L</ok>, L</is>, L</isnt>, L</like>, L</unlike>, L</cmp_ok> and L</is_deeply> are all guaranteed to return the truth value of the test.
  45
  46 =item *
  47
  48 L</like> and L</unlike> don't special case regular expressions that are passed as C<'/.../'> strings.
  49 A string regexp argument is always treated as the source of the regexp, making C<like $text, $rx> and C<like $text, qr[$rx]> equivalent to each other and to C<cmp_ok $text, '=~', $rx> (and likewise for C<unlike>).
  50
  51 =item *
  52
  53 L</cmp_ok> throws an exception if the given operator isn't a valid Perl binary operator (except C<'='> and variants).
  54 It also tests in scalar context, so C<'..'> will be treated as the flip-flop operator and not the range operator.
  55
  56 =item *
  57
  58 L</is_deeply> doesn't guard for memory cycles.
  59 If the two first arguments present parallel memory cycles, the test may result in an infinite loop.
  60
  61 =item *
  62
  63 The tests don't output any kind of default diagnostic in case of failure ; the rationale being that if you have a large number of tests and a lot of them are failing, then you don't want to be flooded by diagnostics.
  64 Moreover, this allows a much faster variant of L</is_deeply>.
  65
  66 =item *
  67
  68 C<use_ok>, C<require_ok>, C<can_ok>, C<isa_ok>, C<new_ok>, C<subtest>, C<explain>, C<TODO> blocks and C<todo_skip> are not implemented.
  69
  70 =back
  71
  72 =cut
  73
  74 use Exporter ();
  75
  76 my $main_process;
  77
  78 BEGIN {
  79  $main_process = $$;
  80
  81  if ($] >= 5.008 and $INC{'threads.pm'}) {
  82   my $use_ithreads = do {
  83    require Config;
  84    no warnings 'once';
  85    $Config::Config{useithreads};
  86   };
  87   if ($use_ithreads) {
  88    require threads::shared;
  89    *THREADSAFE = sub () { 1 };
  90   }
  91  }
  92  unless (defined &Test::Leaner::THREADSAFE) {
  93   *THREADSAFE = sub () { 0 }
  94  }
  95 }
  96
  97 my ($TAP_STREAM, $DIAG_STREAM);
  98
  99 my ($plan, $test, $failed, $no_diag, $done_testing);
 100
 101 our @EXPORT = qw<
 102  plan
 103  skip
 104  done_testing
 105  pass
 106  fail
 107  ok
 108  is
 109  isnt
 110  like
 111  unlike
 112  cmp_ok
 113  is_deeply
 114  diag
 115  note
 116  BAIL_OUT
 117 >;
 118
 119 =head1 ENVIRONMENT
 120
 121 =head2 C<PERL_TEST_LEANER_USES_TEST_MORE>
 122
 123 If this environment variable is set, L<Test::Leaner> will replace its functions by those from L<Test::More>.
 124 Moreover, the symbols that are imported when you C<use Test::Leaner> will be those from L<Test::More>, but you can still only import the symbols originally defined in L<Test::Leaner> (hence the functions from L<Test::More> that are not implemented in L<Test::Leaner> will not be imported).
 125 If your version of L<Test::More> is too old and doesn't have some symbols (like L</note> or L</done_testing>), they will be replaced in L<Test::Leaner> by croaking stubs.
 126
 127 This may be useful if your L<Test::Leaner>-based test script fails and you want extra diagnostics.
 128
 129 =cut
 130
 131 sub _handle_import_args {
 132  my @imports;
 133
 134  my $i = 0;
 135  while ($i <= $#_) {
 136   my $item = $_[$i];
 137   my $splice;
 138   if (defined $item) {
 139    if ($item eq 'import') {
 140     push @imports, @{ $_[$i+1] };
 141     $splice  = 2;
 142    } elsif ($item eq 'no_diag') {
 143     lock $plan if THREADSAFE;
 144     $no_diag = 1;
 145     $splice  = 1;
 146    }
 147   }
 148   if ($splice) {
 149    splice @_, $i, $splice;
 150   } else {
 151    ++$i;
 152   }
 153  }
 154
 155  return @imports;
 156 }
 157
 158 if ($ENV{PERL_TEST_LEANER_USES_TEST_MORE}) {
 159  require Test::More;
 160
 161  my $leaner_stash = \%Test::Leaner::;
 162  my $more_stash   = \%Test::More::;
 163
 164  my %valid_imports;
 165
 166  for (@EXPORT) {
 167   my $replacement = exists $more_stash->{$_} ? *{$more_stash->{$_}}{CODE}
 168                                              : undef;
 169   if (defined $replacement) {
 170    $valid_imports{$_} = 1;
 171   } else {
 172    $replacement = sub {
 173     @_ = ("$_ is not implemented in this version of Test::More");
 174     goto &croak;
 175    };
 176   }
 177   no warnings 'redefine';
 178   $leaner_stash->{$_} = $replacement;
 179  }
 180
 181  my $import = sub {
 182   shift;
 183
 184   my @imports = &_handle_import_args;
 185   @imports = @EXPORT unless @imports;
 186   my @test_more_imports;
 187   for (@imports) {
 188    if ($valid_imports{$_}) {
 189     push @test_more_imports, $_;
 190    } else {
 191     my $pkg = caller;
 192     no strict 'refs';
 193     *{$pkg."::$_"} = $leaner_stash->{$_};
 194    }
 195   }
 196
 197   my $test_more_import = 'Test::More'->can('import');
 198   return unless $test_more_import;
 199
 200   @_ = (
 201    'Test::More',
 202    @_,
 203    import => \@test_more_imports,
 204   );
 205   {
 206    lock $plan if THREADSAFE;
 207    push @_, 'no_diag' if $no_diag;
 208   }
 209
 210   goto $test_more_import;
 211  };
 212
 213  no warnings 'redefine';
 214  *import = $import;
 215
 216  return 1;
 217 }
 218
 219 sub NO_PLAN  () { -1 }
 220 sub SKIP_ALL () { -2 }
 221
 222 BEGIN {
 223  if (THREADSAFE) {
 224   threads::shared::share($_) for $plan, $test, $failed, $no_diag, $done_testing;
 225  }
 226
 227  lock $plan if THREADSAFE;
 228
 229  $plan   = undef;
 230  $test   = 0;
 231  $failed = 0;
 232 }
 233
 234 sub carp {
 235  my $level = 1 + ($Test::Builder::Level || 0);
 236  my @caller;
 237  do {
 238   @caller = caller $level--;
 239  } while (!@caller and $level >= 0);
 240  my ($file, $line) = @caller[1, 2];
 241  warn @_, " at $file line $line.\n";
 242 }
 243
 244 sub croak {
 245  my $level = 1 + ($Test::Builder::Level || 0);
 246  my @caller;
 247  do {
 248   @caller = caller $level--;
 249  } while (!@caller and $level >= 0);
 250  my ($file, $line) = @caller[1, 2];
 251  die @_, " at $file line $line.\n";
 252 }
 253
 254 sub _sanitize_comment {
 255  $_[0] =~ s/\n+\z//;
 256  $_[0] =~ s/#/\\#/g;
 257  $_[0] =~ s/\n/\n# /g;
 258 }
 259
 260 =head1 FUNCTIONS
 261
 262 The following functions from L<Test::More> are implemented and exported by default.
 263
 264 =head2 C<< plan [ tests => $count | 'no_plan' | skip_all => $reason ] >>
 265
 266 See L<Test::More/plan>.
 267
 268 =cut
 269
 270 sub plan {
 271  my ($key, $value) = @_;
 272
 273  return unless $key;
 274
 275  lock $plan if THREADSAFE;
 276
 277  croak("You tried to plan twice") if defined $plan;
 278
 279  my $plan_str;
 280
 281  if ($key eq 'no_plan') {
 282   croak("no_plan takes no arguments") if $value;
 283   $plan       = NO_PLAN;
 284  } elsif ($key eq 'tests') {
 285   croak("Got an undefined number of tests") unless defined $value;
 286   croak("You said to run 0 tests")          unless $value;
 287   croak("Number of tests must be a positive integer.  You gave it '$value'")
 288                                             unless $value =~ /^\+?[0-9]+$/;
 289   $plan       = $value;
 290   $plan_str   = "1..$value";
 291  } elsif ($key eq 'skip_all') {
 292   $plan       = SKIP_ALL;
 293   $plan_str   = '1..0 # SKIP';
 294   if (defined $value) {
 295    _sanitize_comment($value);
 296    $plan_str .= " $value" if length $value;
 297   }
 298  } else {
 299   my @args = grep defined, $key, $value;
 300   croak("plan() doesn't understand @args");
 301  }
 302
 303  if (defined $plan_str) {
 304   local $\;
 305   print $TAP_STREAM "$plan_str\n";
 306  }
 307
 308  exit 0 if $plan == SKIP_ALL;
 309
 310  return 1;
 311 }
 312
 313 sub import {
 314  my $class = shift;
 315
 316  my @imports = &_handle_import_args;
 317
 318  if (@_) {
 319   local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
 320   &plan;
 321  }
 322
 323  @_ = ($class, @imports);
 324  goto &Exporter::import;
 325 }
 326
 327 =head2 C<< skip $reason => $count >>
 328
 329 See L<Test::More/skip>.
 330
 331 =cut
 332
 333 sub skip {
 334  my ($reason, $count) = @_;
 335
 336  lock $plan if THREADSAFE;
 337
 338  if (not defined $count) {
 339   carp("skip() needs to know \$how_many tests are in the block")
 340                                       unless defined $plan and $plan == NO_PLAN;
 341   $count = 1;
 342  } elsif ($count =~ /[^0-9]/) {
 343   carp('skip() was passed a non-numeric number of tests.  Did you get the arguments backwards?');
 344   $count = 1;
 345  }
 346
 347  for (1 .. $count) {
 348   ++$test;
 349
 350   my $skip_str = "ok $test # skip";
 351   if (defined $reason) {
 352    _sanitize_comment($reason);
 353    $skip_str  .= " $reason" if length $reason;
 354   }
 355
 356   local $\;
 357   print $TAP_STREAM "$skip_str\n";
 358  }
 359
 360  no warnings 'exiting';
 361  last SKIP;
 362 }
 363
 364 =head2 C<done_testing [ $count ]>
 365
 366 See L<Test::More/done_testing>.
 367
 368 =cut
 369
 370 sub done_testing {
 371  my ($count) = @_;
 372
 373  lock $plan if THREADSAFE;
 374
 375  $count = $test unless defined $count;
 376  croak("Number of tests must be a positive integer.  You gave it '$count'")
 377                                                  unless $count =~ /^\+?[0-9]+$/;
 378
 379  if (not defined $plan or $plan == NO_PLAN) {
 380   $plan         = $count; # $plan can't be NO_PLAN anymore
 381   $done_testing = 1;
 382   local $\;
 383   print $TAP_STREAM "1..$plan\n";
 384  } else {
 385   if ($done_testing) {
 386    @_ = ('done_testing() was already called');
 387    goto &fail;
 388   } elsif ($plan != $count) {
 389    @_ = ("planned to run $plan tests but done_testing() expects $count");
 390    goto &fail;
 391   }
 392  }
 393
 394  return 1;
 395 }
 396
 397 =head2 C<ok $ok [, $desc ]>
 398
 399 See L<Test::More/ok>.
 400
 401 =cut
 402
 403 sub ok ($;$) {
 404  my ($ok, $desc) = @_;
 405
 406  lock $plan if THREADSAFE;
 407
 408  ++$test;
 409
 410  my $test_str = "ok $test";
 411  $ok or do {
 412   $test_str   = "not $test_str";
 413   ++$failed;
 414  };
 415  if (defined $desc) {
 416   _sanitize_comment($desc);
 417   $test_str .= " - $desc" if length $desc;
 418  }
 419
 420  local $\;
 421  print $TAP_STREAM "$test_str\n";
 422
 423  return $ok;
 424 }
 425
 426 =head2 C<pass [ $desc ]>
 427
 428 See L<Test::More/pass>.
 429
 430 =cut
 431
 432 sub pass (;$) {
 433  unshift @_, 1;
 434  goto &ok;
 435 }
 436
 437 =head2 C<fail [ $desc ]>
 438
 439 See L<Test::More/fail>.
 440
 441 =cut
 442
 443 sub fail (;$) {
 444  unshift @_, 0;
 445  goto &ok;
 446 }
 447
 448 =head2 C<is $got, $expected [, $desc ]>
 449
 450 See L<Test::More/is>.
 451
 452 =cut
 453
 454 sub is ($$;$) {
 455  my ($got, $expected, $desc) = @_;
 456  no warnings 'uninitialized';
 457  @_ = (
 458   (not(defined $got xor defined $expected) and $got eq $expected),
 459   $desc,
 460  );
 461  goto &ok;
 462 }
 463
 464 =head2 C<isnt $got, $expected [, $desc ]>
 465
 466 See L<Test::More/isnt>.
 467
 468 =cut
 469
 470 sub isnt ($$;$) {
 471  my ($got, $expected, $desc) = @_;
 472  no warnings 'uninitialized';
 473  @_ = (
 474   ((defined $got xor defined $expected) or $got ne $expected),
 475   $desc,
 476  );
 477  goto &ok;
 478 }
 479
 480 my %binops = (
 481  'or'  => 'or',
 482  'xor' => 'xor',
 483  'and' => 'and',
 484
 485  '||'  => 'hor',
 486  ('//' => 'dor') x ($] >= 5.010),
 487  '&&'  => 'hand',
 488
 489  '|'   => 'bor',
 490  '^'   => 'bxor',
 491  '&'   => 'band',
 492
 493  'lt'  => 'lt',
 494  'le'  => 'le',
 495  'gt'  => 'gt',
 496  'ge'  => 'ge',
 497  'eq'  => 'eq',
 498  'ne'  => 'ne',
 499  'cmp' => 'cmp',
 500
 501  '<'   => 'nlt',
 502  '<='  => 'nle',
 503  '>'   => 'ngt',
 504  '>='  => 'nge',
 505  '=='  => 'neq',
 506  '!='  => 'nne',
 507  '<=>' => 'ncmp',
 508
 509  '=~'  => 'like',
 510  '!~'  => 'unlike',
 511  ('~~' => 'smartmatch') x ($] >= 5.010),
 512
 513  '+'   => 'add',
 514  '-'   => 'substract',
 515  '*'   => 'multiply',
 516  '/'   => 'divide',
 517  '%'   => 'modulo',
 518  '<<'  => 'lshift',
 519  '>>'  => 'rshift',
 520
 521  '.'   => 'concat',
 522  '..'  => 'flipflop',
 523  '...' => 'altflipflop',
 524  ','   => 'comma',
 525  '=>'  => 'fatcomma',
 526 );
 527
 528 my %binop_handlers;
 529
 530 sub _create_binop_handler {
 531  my ($op) = @_;
 532  my $name = $binops{$op};
 533  croak("Operator $op not supported") unless defined $name;
 534  {
 535   local $@;
 536   eval <<"IS_BINOP";
 537 sub is_$name (\$\$;\$) {
 538  my (\$got, \$expected, \$desc) = \@_;
 539  \@_ = (scalar(\$got $op \$expected), \$desc);
 540  goto &ok;
 541 }
 542 IS_BINOP
 543   die $@ if $@;
 544  }
 545  $binop_handlers{$op} = do {
 546   no strict 'refs';
 547   \&{__PACKAGE__."::is_$name"};
 548  }
 549 }
 550
 551 =head2 C<like $got, $regexp_expected [, $desc ]>
 552
 553 See L<Test::More/like>.
 554
 555 =head2 C<unlike $got, $regexp_expected, [, $desc ]>
 556
 557 See L<Test::More/unlike>.
 558
 559 =cut
 560
 561 {
 562  no warnings 'once';
 563  *like   = _create_binop_handler('=~');
 564  *unlike = _create_binop_handler('!~');
 565 }
 566
 567 =head2 C<cmp_ok $got, $op, $expected [, $desc ]>
 568
 569 See L<Test::More/cmp_ok>.
 570
 571 =cut
 572
 573 sub cmp_ok ($$$;$) {
 574  my ($got, $op, $expected, $desc) = @_;
 575  my $handler = $binop_handlers{$op};
 576  unless ($handler) {
 577   local $Test::More::Level = ($Test::More::Level || 0) + 1;
 578   $handler = _create_binop_handler($op);
 579  }
 580  @_ = ($got, $expected, $desc);
 581  goto $handler;
 582 }
 583
 584 =head2 C<is_deeply $got, $expected [, $desc ]>
 585
 586 See L<Test::More/is_deeply>.
 587
 588 =cut
 589
 590 BEGIN {
 591  local $@;
 592  if (eval { require Scalar::Util; 1 }) {
 593   *_reftype = \&Scalar::Util::reftype;
 594  } else {
 595   # Stolen from Scalar::Util::PP
 596   require B;
 597   my %tmap = qw<
 598    B::NULL   SCALAR
 599
 600    B::HV     HASH
 601    B::AV     ARRAY
 602    B::CV     CODE
 603    B::IO     IO
 604    B::GV     GLOB
 605    B::REGEXP REGEXP
 606   >;
 607   *_reftype = sub ($) {
 608    my $r = shift;
 609
 610    return undef unless length ref $r;
 611
 612    my $t = ref B::svref_2object($r);
 613
 614    return exists $tmap{$t} ? $tmap{$t}
 615                            : length ref $$r ? 'REF'
 616                                             : 'SCALAR'
 617   }
 618  }
 619 }
 620
 621 sub _deep_ref_check {
 622  my ($x, $y, $ry) = @_;
 623
 624  no warnings qw<numeric uninitialized>;
 625
 626  if ($ry eq 'ARRAY') {
 627   return 0 unless $#$x == $#$y;
 628
 629   my ($ex, $ey);
 630   for (0 .. $#$y) {
 631    $ex = $x->[$_];
 632    $ey = $y->[$_];
 633
 634    # Inline the beginning of _deep_check
 635    return 0 if defined $ex xor defined $ey;
 636
 637    next if not(ref $ex xor ref $ey) and $ex eq $ey;
 638
 639    $ry = _reftype($ey);
 640    return 0 if _reftype($ex) ne $ry;
 641
 642    return 0 unless $ry and _deep_ref_check($ex, $ey, $ry);
 643   }
 644
 645   return 1;
 646  } elsif ($ry eq 'HASH') {
 647   return 0 unless keys(%$x) == keys(%$y);
 648
 649   my ($ex, $ey);
 650   for (keys %$y) {
 651    return 0 unless exists $x->{$_};
 652    $ex = $x->{$_};
 653    $ey = $y->{$_};
 654
 655    # Inline the beginning of _deep_check
 656    return 0 if defined $ex xor defined $ey;
 657
 658    next if not(ref $ex xor ref $ey) and $ex eq $ey;
 659
 660    $ry = _reftype($ey);
 661    return 0 if _reftype($ex) ne $ry;
 662
 663    return 0 unless $ry and _deep_ref_check($ex, $ey, $ry);
 664   }
 665
 666   return 1;
 667  } elsif ($ry eq 'SCALAR' or $ry eq 'REF') {
 668   return _deep_check($$x, $$y);
 669  }
 670
 671  return 0;
 672 }
 673
 674 sub _deep_check {
 675  my ($x, $y) = @_;
 676
 677  no warnings qw<numeric uninitialized>;
 678
 679  return 0 if defined $x xor defined $y;
 680
 681  # Try object identity/eq overloading first. It also covers the case where
 682  # $x and $y are both undefined.
 683  # If either $x or $y is overloaded but none has eq overloading, the test will
 684  # break at that point.
 685  return 1 if not(ref $x xor ref $y) and $x eq $y;
 686
 687  # Test::More::is_deeply happily breaks encapsulation if the objects aren't
 688  # overloaded.
 689  my $ry = _reftype($y);
 690  return 0 if _reftype($x) ne $ry;
 691
 692  # Shortcut if $x and $y are both not references and failed the previous
 693  # $x eq $y test.
 694  return 0 unless $ry;
 695
 696  # We know that $x and $y are both references of type $ry, without overloading.
 697  _deep_ref_check($x, $y, $ry);
 698 }
 699
 700 sub is_deeply {
 701  @_ = (
 702   &_deep_check,
 703   $_[2],
 704  );
 705  goto &ok;
 706 }
 707
 708 sub _diag_fh {
 709  my $fh = shift;
 710
 711  return unless @_;
 712
 713  lock $plan if THREADSAFE;
 714  return if $no_diag;
 715
 716  my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
 717  _sanitize_comment($msg);
 718  return unless length $msg;
 719
 720  local $\;
 721  print $fh "# $msg\n";
 722
 723  return 0;
 724 };
 725
 726 =head2 C<diag @text>
 727
 728 See L<Test::More/diag>.
 729
 730 =cut
 731
 732 sub diag {
 733  unshift @_, $DIAG_STREAM;
 734  goto &_diag_fh;
 735 }
 736
 737 =head2 C<note @text>
 738
 739 See L<Test::More/note>.
 740
 741 =cut
 742
 743 sub note {
 744  unshift @_, $TAP_STREAM;
 745  goto &_diag_fh;
 746 }
 747
 748 =head2 C<BAIL_OUT [ $desc ]>
 749
 750 See L<Test::More/BAIL_OUT>.
 751
 752 =cut
 753
 754 sub BAIL_OUT {
 755  my ($desc) = @_;
 756
 757  lock $plan if THREADSAFE;
 758
 759  my $bail_out_str = 'Bail out!';
 760  if (defined $desc) {
 761   _sanitize_comment($desc);
 762   $bail_out_str  .= "  $desc" if length $desc; # Two spaces
 763  }
 764
 765  local $\;
 766  print $TAP_STREAM "$bail_out_str\n";
 767
 768  exit 255;
 769 }
 770
 771 END {
 772  if ($main_process == $$ and not $?) {
 773   lock $plan if THREADSAFE;
 774
 775   if (defined $plan) {
 776    if ($failed) {
 777     $? = $failed <= 254 ? $failed : 254;
 778    } elsif ($plan >= 0) {
 779     $? = $test == $plan ? 0 : 255;
 780    }
 781    if ($plan == NO_PLAN) {
 782     local $\;
 783     print $TAP_STREAM "1..$test\n";
 784    }
 785   }
 786  }
 787 }
 788
 789 =pod
 790
 791 L<Test::Leaner> also provides some functions of its own, which are never exported.
 792
 793 =head2 C<tap_stream [ $fh ]>
 794
 795 Read/write accessor for the filehandle to which the tests are outputted.
 796 On write, it also turns autoflush on onto C<$fh>.
 797
 798 Note that it can only be used as a write accessor before you start any thread, as L<threads::shared> cannot reliably share filehandles.
 799
 800 Defaults to C<STDOUT>.
 801
 802 =cut
 803
 804 sub tap_stream (;*) {
 805  if (@_) {
 806   $TAP_STREAM = $_[0];
 807
 808   my $fh = select $TAP_STREAM;
 809   $|++;
 810   select $fh;
 811  }
 812
 813  return $TAP_STREAM;
 814 }
 815
 816 tap_stream *STDOUT;
 817
 818 =head2 C<diag_stream [ $fh ]>
 819
 820 Read/write accessor for the filehandle to which the diagnostics are printed.
 821 On write, it also turns autoflush on onto C<$fh>.
 822
 823 Just like L</tap_stream>, it can only be used as a write accessor before you start any thread, as L<threads::shared> cannot reliably share filehandles.
 824
 825 Defaults to C<STDERR>.
 826
 827 =cut
 828
 829 sub diag_stream (;*) {
 830  if (@_) {
 831   $DIAG_STREAM = $_[0];
 832
 833   my $fh = select $DIAG_STREAM;
 834   $|++;
 835   select $fh;
 836  }
 837
 838  return $DIAG_STREAM;
 839 }
 840
 841 diag_stream *STDERR;
 842
 843 =head2 C<THREADSAFE>
 844
 845 This constant evaluates to true if and only if L<Test::Leaner> is thread-safe, i.e. when this version of C<perl> is at least 5.8, has been compiled with C<useithreads> defined, and L<threads> has been loaded B<before> L<Test::Leaner>.
 846 In that case, it also needs a working L<threads::shared>.
 847
 848 =head1 DEPENDENCIES
 849
 850 L<perl> 5.6.
 851
 852 L<Exporter>, L<Test::More>.
 853
 854 =head1 AUTHOR
 855
 856 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 857
 858 You can contact me by mail or on C<irc.perl.org> (vincent).
 859
 860 =head1 BUGS
 861
 862 Please report any bugs or feature requests to C<bug-test-leaner at rt.cpan.org>, or through the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Leaner>.
 863 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 864
 865 =head1 SUPPORT
 866
 867 You can find documentation for this module with the perldoc command.
 868
 869     perldoc Test::Leaner
 870
 871 =head1 COPYRIGHT & LICENSE
 872
 873 Copyright 2010,2011 Vincent Pit, all rights reserved.
 874
 875 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 876
 877 =cut
 878
 879 1; # End of Test::Leaner