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