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.01
  14
  15 =cut
  16
  17 our $VERSION = '0.01';
  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> honors C<'eq'> 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> and L</cmp_ok> are all guaranteed to return the truth value of the test.
  45
  46 =item *
  47
  48 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.
  49
  50 =back
  51
  52 =cut
  53
  54 use Exporter ();
  55
  56 BEGIN {
  57  if ($] >= 5.008 and $INC{'threads.pm'}) {
  58   my $use_ithreads = do {
  59    require Config;
  60    no warnings 'once';
  61    $Config::Config{useithreads};
  62   };
  63   if ($use_ithreads) {
  64    require threads::shared;
  65    *THREADSAFE = sub () { 1 };
  66   }
  67  }
  68  unless (defined &Test::Leaner::THREADSAFE) {
  69   *THREADSAFE = sub () { 0 }
  70  }
  71 }
  72
  73 my ($TAP_STREAM, $DIAG_STREAM);
  74
  75 my ($plan, $test, $failed, $no_diag, $done_testing);
  76
  77 sub NO_PLAN  () { -1 }
  78 sub SKIP_ALL () { -2 }
  79
  80 BEGIN {
  81  if (THREADSAFE) {
  82   threads::shared::share($_) for $plan, $test, $failed, $no_diag, $done_testing;
  83  }
  84
  85  lock $plan if THREADSAFE;
  86
  87  $plan   = undef;
  88  $test   = 0;
  89  $failed = 0;
  90 }
  91
  92 sub carp {
  93  my $level = 1 + ($Test::Builder::Level || 0);
  94  my ($file, $line) = (caller $level)[1, 2];
  95  warn @_, " at $file line $line.\n";
  96 }
  97
  98 sub croak {
  99  my $level = 1 + ($Test::Builder::Level || 0);
 100  my ($file, $line) = (caller $level)[1, 2];
 101  die @_, " at $file line $line.\n";
 102 }
 103
 104 sub sanitize_comment {
 105  $_[0] =~ s/\n+\z//;
 106  $_[0] =~ s/#/\\#/g;
 107  $_[0] =~ s/\n/\n# /g;
 108 }
 109
 110 =head1 FUNCTIONS
 111
 112 The following functions from L<Test::More> are implemented and exported by default.
 113
 114 =head2 C<< plan [ tests => $count | 'no_plan' | skip_all => $reason ] >>
 115
 116 =cut
 117
 118 sub plan {
 119  my ($key, $value) = @_;
 120
 121  return unless $key;
 122
 123  lock $plan if THREADSAFE;
 124
 125  croak("You tried to plan twice") if defined $plan;
 126
 127  my $plan_str;
 128
 129  if ($key eq 'no_plan') {
 130   croak("no_plan takes no arguments") if $value;
 131   $plan       = NO_PLAN;
 132  } elsif ($key eq 'tests') {
 133   croak("Got an undefined number of tests") unless defined $value;
 134   croak("You said to run 0 tests")          unless $value;
 135   croak("Number of tests must be a positive integer.  You gave it '$value'")
 136                                             unless $value =~ /^\+?[0-9]+$/;
 137   $plan       = $value;
 138   $plan_str   = "1..$value";
 139  } elsif ($key eq 'skip_all') {
 140   $plan       = SKIP_ALL;
 141   $plan_str   = '1..0 # SKIP';
 142   if (defined $value) {
 143    sanitize_comment($value);
 144    $plan_str .= " $value" if length $value;
 145   }
 146  } else {
 147   my @args = grep defined, $key, $value;
 148   croak("plan() doesn't understand @args");
 149  }
 150
 151  if (defined $plan_str) {
 152   local $\;
 153   print $TAP_STREAM "$plan_str\n";
 154  }
 155
 156  exit 0 if $plan == SKIP_ALL;
 157
 158  return 1;
 159 }
 160
 161 our @EXPORT = qw<
 162  plan
 163  skip
 164  done_testing
 165  pass
 166  fail
 167  ok
 168  is
 169  isnt
 170  cmp_ok
 171  like
 172  unlike
 173  diag
 174  note
 175  BAIL_OUT
 176 >;
 177
 178 sub import {
 179  my $class = shift;
 180
 181  my @imports;
 182  my $i = 0;
 183  while ($i <= $#_) {
 184   my $item = $_[$i];
 185   my $splice;
 186   if (defined $item) {
 187    if ($item eq 'import') {
 188     push @imports, @{ $_[$i+1] };
 189     $splice  = 2;
 190    } elsif ($item eq 'no_diag') {
 191     lock $plan if THREADSAFE;
 192     $no_diag = 1;
 193     $splice  = 1;
 194    }
 195   }
 196   if ($splice) {
 197    splice @_, $i, $splice;
 198   } else {
 199    ++$i;
 200   }
 201  }
 202
 203  if (@_) {
 204   local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
 205   &plan;
 206  }
 207
 208  @_ = ($class, @imports);
 209  goto &Exporter::import;
 210 }
 211
 212 =head2 C<< skip $reason => $count >>
 213
 214 =cut
 215
 216 sub skip {
 217  my ($reason, $count) = @_;
 218
 219  lock $plan if THREADSAFE;
 220
 221  if (not defined $count) {
 222   carp("skip() needs to know \$how_many tests are in the block")
 223                                       unless defined $plan and $plan == NO_PLAN;
 224   $count = 1;
 225  } elsif ($count =~ /[^0-9]/) {
 226   carp('skip() was passed a non-numeric number of tests.  Did you get the arguments backwards?');
 227   $count = 1;
 228  }
 229
 230  for (1 .. $count) {
 231   ++$test;
 232
 233   my $skip_str = "ok $test # skip";
 234   if (defined $reason) {
 235    sanitize_comment($reason);
 236    $skip_str  .= " $reason" if length $reason;
 237   }
 238
 239   local $\;
 240   print $TAP_STREAM "$skip_str\n";
 241  }
 242
 243  no warnings 'exiting';
 244  last SKIP;
 245 }
 246
 247 =head2 C<done_testing [ $count ]>
 248
 249 =cut
 250
 251 sub done_testing {
 252  my ($count) = @_;
 253
 254  lock $plan if THREADSAFE;
 255
 256  $count = $test unless defined $count;
 257  croak("Number of tests must be a positive integer.  You gave it '$count'")
 258                                                  unless $count =~ /^\+?[0-9]+$/;
 259
 260  if (not defined $plan or $plan == NO_PLAN) {
 261   $plan         = $count; # $plan can't be NO_PLAN anymore
 262   $done_testing = 1;
 263   local $\;
 264   print $TAP_STREAM "1..$plan\n";
 265  } else {
 266   if ($done_testing) {
 267    @_ = ('done_testing() was already called');
 268    goto &fail;
 269   } elsif ($plan != $count) {
 270    @_ = ("planned to run $plan tests but done_testing() expects $count");
 271    goto &fail;
 272   }
 273  }
 274
 275  return 1;
 276 }
 277
 278 =head2 C<ok $ok [, $desc ]>
 279
 280 =cut
 281
 282 sub ok ($;$) {
 283  my ($ok, $desc) = @_;
 284
 285  lock $plan if THREADSAFE;
 286
 287  ++$test;
 288
 289  my $test_str = "ok $test";
 290  unless ($ok) {
 291   $test_str   = "not $test_str";
 292   ++$failed;
 293  }
 294  if (defined $desc) {
 295   sanitize_comment($desc);
 296   $test_str .= " - $desc" if length $desc;
 297  }
 298
 299  local $\;
 300  print $TAP_STREAM "$test_str\n";
 301
 302  return $ok;
 303 }
 304
 305 =head2 C<pass [ $desc ]>
 306
 307 =cut
 308
 309 sub pass (;$) {
 310  unshift @_, 1;
 311  goto &ok;
 312 }
 313
 314 =head2 C<fail [ $desc ]>
 315
 316 =cut
 317
 318 sub fail (;$) {
 319  unshift @_, 0;
 320  goto &ok;
 321 }
 322
 323 =head2 C<is $got, $expected [, $desc ]>
 324
 325 =cut
 326
 327 sub is ($$;$) {
 328  my ($got, $expected, $desc) = @_;
 329  no warnings 'uninitialized';
 330  @_ = (
 331   (not(defined $got xor defined $expected) and $got eq $expected),
 332   $desc,
 333  );
 334  goto &ok;
 335 }
 336
 337 =head2 C<isnt $got, $expected [, $desc ]>
 338
 339 =cut
 340
 341 sub isnt ($$;$) {
 342  my ($got, $expected, $desc) = @_;
 343  no warnings 'uninitialized';
 344  @_ = (
 345   ((defined $got xor defined $expected) or $got ne $expected),
 346   $desc,
 347  );
 348  goto &ok;
 349 }
 350
 351 my %binops = (
 352  'or'  => 'or',
 353  'and' => 'and',
 354  'xor' => 'xor',
 355
 356  '||'  => 'hor',
 357  '&&'  => 'hand',
 358
 359  'lt'  => 'lt',
 360  'le'  => 'le',
 361  'gt'  => 'gt',
 362  'ge'  => 'ge',
 363  'eq'  => 'eq',
 364  'ne'  => 'ne',
 365  'cmp' => 'cmp',
 366
 367  '<'   => 'nlt',
 368  '<='  => 'nle',
 369  '>'   => 'ngt',
 370  '>='  => 'nge',
 371  '=='  => 'neq',
 372  '!='  => 'nne',
 373  '<=>' => 'ncmp',
 374
 375  '=~'  => 'like',
 376  '!~'  => 'unlike',
 377  '~~'  => 'smartmatch',
 378 );
 379
 380 my %binop_handlers;
 381
 382 sub _create_binop_handler {
 383  my ($op) = @_;
 384  my $name = $binops{$op};
 385  croak("Operator $op not supported") unless defined $name;
 386  {
 387   local $@;
 388   eval <<"IS_BINOP";
 389 sub is_$name (\$\$;\$) {
 390  my (\$got, \$expected, \$desc) = \@_;
 391  \@_ = ((\$got $op \$expected), \$desc);
 392  goto &ok;
 393 }
 394 IS_BINOP
 395   die $@ if $@;
 396  }
 397  $binop_handlers{$op} = do {
 398   no strict 'refs';
 399   \&{__PACKAGE__."::is_$name"};
 400  }
 401 }
 402
 403 =head2 C<like $got, $regexp_expected [, $desc ]>
 404
 405 =head2 C<unlike $got, $regexp_expected, [, $desc ]>
 406
 407 =cut
 408
 409 {
 410  no warnings 'once';
 411  *like   = _create_binop_handler('=~');
 412  *unlike = _create_binop_handler('!~');
 413 }
 414
 415 =head2 C<cmp_ok $got, $op, $expected [, $desc ]>
 416
 417 =cut
 418
 419 sub cmp_ok ($$$;$) {
 420  my ($got, $op, $expected, $desc) = @_;
 421  my $handler = $binop_handlers{$op};
 422  unless ($handler) {
 423   local $Test::More::Level = ($Test::More::Level || 0) + 1;
 424   $handler = _create_binop_handler($op);
 425  }
 426  @_ = ($got, $expected, $desc);
 427  goto $handler;
 428 }
 429
 430 sub _diag_fh {
 431  my $fh = shift;
 432
 433  return unless @_;
 434
 435  lock $plan if THREADSAFE;
 436  return if $no_diag;
 437
 438  my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
 439  sanitize_comment($msg);
 440  return unless length $msg;
 441
 442  local $\;
 443  print $fh "# $msg\n";
 444
 445  return 0;
 446 };
 447
 448 =head2 C<diag @text>
 449
 450 =cut
 451
 452 sub diag {
 453  unshift @_, $DIAG_STREAM;
 454  goto &_diag_fh;
 455 }
 456
 457 =head2 C<note @text>
 458
 459 =cut
 460
 461 sub note {
 462  unshift @_, $TAP_STREAM;
 463  goto &_diag_fh;
 464 }
 465
 466 =head2 C<BAIL_OUT [ $desc ]>
 467
 468 =cut
 469
 470 sub BAIL_OUT {
 471  my ($desc) = @_;
 472
 473  lock $plan if THREADSAFE;
 474
 475  my $bail_out_str = 'Bail out!';
 476  if (defined $desc) {
 477   sanitize_comment($desc);
 478   $bail_out_str  .= "  $desc" if length $desc; # Two spaces
 479  }
 480
 481  local $\;
 482  print $TAP_STREAM "$bail_out_str\n";
 483
 484  exit 255;
 485 }
 486
 487 END {
 488  unless ($?) {
 489   lock $plan if THREADSAFE;
 490
 491   if (defined $plan) {
 492    if ($failed) {
 493     $? = $failed <= 254 ? $failed : 254;
 494    } elsif ($plan >= 0) {
 495     $? = $test == $plan ? 0 : 255;
 496    } elsif ($plan == NO_PLAN) {
 497     local $\;
 498     print $TAP_STREAM "1..$test\n";
 499    }
 500   }
 501  }
 502 }
 503
 504 =pod
 505
 506 L<Test::Leaner> also provides some functions of its own, which are never exported.
 507
 508 =head2 C<tap_stream [ $fh ]>
 509
 510 Read/write accessor for the filehandle to which the tests are outputted.
 511 On write, it also turns autoflush on onto C<$fh>.
 512
 513 Note that it can only be used as a write accessor before you start any thread, as L<threads::shared> cannot reliably share filehandles.
 514
 515 Defaults to C<STDOUT>.
 516
 517 =cut
 518
 519 sub tap_stream (;*) {
 520  if (@_) {
 521   $TAP_STREAM = $_[0];
 522
 523   my $fh = select $TAP_STREAM;
 524   $|++;
 525   select $fh;
 526  }
 527
 528  return $TAP_STREAM;
 529 }
 530
 531 tap_stream *STDOUT;
 532
 533 =head2 C<diag_stream [ $fh ]>
 534
 535 Read/write accessor for the filehandle to which the diagnostics are printed.
 536 On write, it also turns autoflush on onto C<$fh>.
 537
 538 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.
 539
 540 Defaults to C<STDERR>.
 541
 542 =cut
 543
 544 sub diag_stream (;*) {
 545  if (@_) {
 546   $DIAG_STREAM = $_[0];
 547
 548   my $fh = select $DIAG_STREAM;
 549   $|++;
 550   select $fh;
 551  }
 552
 553  return $DIAG_STREAM;
 554 }
 555
 556 diag_stream *STDERR;
 557
 558 =head1 DEPENDENCIES
 559
 560 L<perl> 5.6.
 561
 562 L<Exporter>, L<Test::More>
 563
 564 =head1 AUTHOR
 565
 566 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 567
 568 You can contact me by mail or on C<irc.perl.org> (vincent).
 569
 570 =head1 BUGS
 571
 572 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>.
 573 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 574
 575 =head1 SUPPORT
 576
 577 You can find documentation for this module with the perldoc command.
 578
 579     perldoc Test::Leaner
 580
 581 =head1 COPYRIGHT & LICENSE
 582
 583 Copyright 2010 Vincent Pit, all rights reserved.
 584
 585 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 586
 587 =cut
 588
 589 1; # End of Test::Leaner