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_all
 164  skip
 165  done_testing
 166  pass
 167  fail
 168  ok
 169  is
 170  isnt
 171  cmp_ok
 172  like
 173  unlike
 174  diag
 175  note
 176  BAIL_OUT
 177 >;
 178
 179 sub import {
 180  my $class = shift;
 181
 182  my @imports;
 183  my $i = 0;
 184  while ($i <= $#_) {
 185   my $item = $_[$i];
 186   my $splice;
 187   if (defined $item) {
 188    if ($item eq 'import') {
 189     push @imports, @{ $_[$i+1] };
 190     $splice  = 2;
 191    } elsif ($item eq 'no_diag') {
 192     lock $plan if THREADSAFE;
 193     $no_diag = 1;
 194     $splice  = 1;
 195    }
 196   }
 197   if ($splice) {
 198    splice @_, $i, $splice;
 199   } else {
 200    ++$i;
 201   }
 202  }
 203
 204  if (@_) {
 205   local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
 206   &plan;
 207  }
 208
 209  @_ = ($class, @imports);
 210  goto &Exporter::import;
 211 }
 212
 213 =head2 C<skip_all $reason>
 214
 215 =cut
 216
 217 sub skip_all {
 218  @_ = (skip_all => $_[0]);
 219  goto &plan;
 220 }
 221
 222 =head2 C<< skip $reason => $count >>
 223
 224 =cut
 225
 226 sub skip {
 227  my ($reason, $count) = @_;
 228
 229  lock $plan if THREADSAFE;
 230
 231  if (not defined $count) {
 232   carp("skip() needs to know \$how_many tests are in the block")
 233                                       unless defined $plan and $plan == NO_PLAN;
 234   $count = 1;
 235  } elsif ($count =~ /[^0-9]/) {
 236   carp('skip() was passed a non-numeric number of tests.  Did you get the arguments backwards?');
 237   $count = 1;
 238  }
 239
 240  for (1 .. $count) {
 241   ++$test;
 242
 243   my $skip_str = "ok $test # skip";
 244   if (defined $reason) {
 245    sanitize_comment($reason);
 246    $skip_str  .= " $reason" if length $reason;
 247   }
 248
 249   local $\;
 250   print $TAP_STREAM "$skip_str\n";
 251  }
 252
 253  no warnings 'exiting';
 254  last SKIP;
 255 }
 256
 257 =head2 C<done_testing [ $count ]>
 258
 259 =cut
 260
 261 sub done_testing {
 262  my ($count) = @_;
 263
 264  lock $plan if THREADSAFE;
 265
 266  $count = $test unless defined $count;
 267  croak("Number of tests must be a positive integer.  You gave it '$count'")
 268                                                  unless $count =~ /^\+?[0-9]+$/;
 269
 270  if (not defined $plan or $plan == NO_PLAN) {
 271   $plan         = $count; # $plan can't be NO_PLAN anymore
 272   $done_testing = 1;
 273   local $\;
 274   print $TAP_STREAM "1..$plan\n";
 275  } else {
 276   if ($done_testing) {
 277    @_ = ('done_testing() was already called');
 278    goto &fail;
 279   } elsif ($plan != $count) {
 280    @_ = ("planned to run $plan tests but done_testing() expects $count");
 281    goto &fail;
 282   }
 283  }
 284
 285  return 1;
 286 }
 287
 288 =head2 C<ok $ok [, $desc ]>
 289
 290 =cut
 291
 292 sub ok ($;$) {
 293  my ($ok, $desc) = @_;
 294
 295  lock $plan if THREADSAFE;
 296
 297  ++$test;
 298
 299  my $test_str = "ok $test";
 300  unless ($ok) {
 301   $test_str   = "not $test_str";
 302   ++$failed;
 303  }
 304  if (defined $desc) {
 305   sanitize_comment($desc);
 306   $test_str .= " - $desc" if length $desc;
 307  }
 308
 309  local $\;
 310  print $TAP_STREAM "$test_str\n";
 311
 312  return $ok;
 313 }
 314
 315 =head2 C<pass [ $desc ]>
 316
 317 =cut
 318
 319 sub pass (;$) {
 320  unshift @_, 1;
 321  goto &ok;
 322 }
 323
 324 =head2 C<fail [ $desc ]>
 325
 326 =cut
 327
 328 sub fail (;$) {
 329  unshift @_, 0;
 330  goto &ok;
 331 }
 332
 333 =head2 C<is $got, $expected [, $desc ]>
 334
 335 =cut
 336
 337 sub is ($$;$) {
 338  my ($got, $expected, $desc) = @_;
 339  no warnings 'uninitialized';
 340  @_ = (
 341   (not(defined $got xor defined $expected) and $got eq $expected),
 342   $desc,
 343  );
 344  goto &ok;
 345 }
 346
 347 =head2 C<isnt $got, $expected [, $desc ]>
 348
 349 =cut
 350
 351 sub isnt ($$;$) {
 352  my ($got, $expected, $desc) = @_;
 353  no warnings 'uninitialized';
 354  @_ = (
 355   ((defined $got xor defined $expected) or $got ne $expected),
 356   $desc,
 357  );
 358  goto &ok;
 359 }
 360
 361 my %binops = (
 362  'or'  => 'or',
 363  'and' => 'and',
 364  'xor' => 'xor',
 365
 366  '||'  => 'hor',
 367  '&&'  => 'hand',
 368
 369  'lt'  => 'lt',
 370  'le'  => 'le',
 371  'gt'  => 'gt',
 372  'ge'  => 'ge',
 373  'eq'  => 'eq',
 374  'ne'  => 'ne',
 375  'cmp' => 'cmp',
 376
 377  '<'   => 'nlt',
 378  '<='  => 'nle',
 379  '>'   => 'ngt',
 380  '>='  => 'nge',
 381  '=='  => 'neq',
 382  '!='  => 'nne',
 383  '<=>' => 'ncmp',
 384
 385  '=~'  => 'like',
 386  '!~'  => 'unlike',
 387  '~~'  => 'smartmatch',
 388 );
 389
 390 my %binop_handlers;
 391
 392 sub _create_binop_handler {
 393  my ($op) = @_;
 394  my $name = $binops{$op};
 395  croak("Operator $op not supported") unless defined $name;
 396  {
 397   local $@;
 398   eval <<"IS_BINOP";
 399 sub is_$name (\$\$;\$) {
 400  my (\$got, \$expected, \$desc) = \@_;
 401  \@_ = ((\$got $op \$expected), \$desc);
 402  goto &ok;
 403 }
 404 IS_BINOP
 405   die $@ if $@;
 406  }
 407  $binop_handlers{$op} = do {
 408   no strict 'refs';
 409   \&{__PACKAGE__."::is_$name"};
 410  }
 411 }
 412
 413 =head2 C<like $got, $regexp_expected [, $desc ]>
 414
 415 =head2 C<unlike $got, $regexp_expected, [, $desc ]>
 416
 417 =cut
 418
 419 {
 420  no warnings 'once';
 421  *like   = _create_binop_handler('=~');
 422  *unlike = _create_binop_handler('!~');
 423 }
 424
 425 =head2 C<cmp_ok $got, $op, $expected [, $desc ]>
 426
 427 =cut
 428
 429 sub cmp_ok ($$$;$) {
 430  my ($got, $op, $expected, $desc) = @_;
 431  my $handler = $binop_handlers{$op};
 432  unless ($handler) {
 433   local $Test::More::Level = ($Test::More::Level || 0) + 1;
 434   $handler = _create_binop_handler($op);
 435  }
 436  @_ = ($got, $expected, $desc);
 437  goto $handler;
 438 }
 439
 440 sub _diag_fh {
 441  my $fh = shift;
 442
 443  return unless @_;
 444
 445  lock $plan if THREADSAFE;
 446  return if $no_diag;
 447
 448  my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
 449  sanitize_comment($msg);
 450  return unless length $msg;
 451
 452  local $\;
 453  print $fh "# $msg\n";
 454
 455  return 0;
 456 };
 457
 458 =head2 C<diag @text>
 459
 460 =cut
 461
 462 sub diag {
 463  unshift @_, $DIAG_STREAM;
 464  goto &_diag_fh;
 465 }
 466
 467 =head2 C<note @text>
 468
 469 =cut
 470
 471 sub note {
 472  unshift @_, $TAP_STREAM;
 473  goto &_diag_fh;
 474 }
 475
 476 =head2 C<BAIL_OUT [ $desc ]>
 477
 478 =cut
 479
 480 sub BAIL_OUT {
 481  my ($desc) = @_;
 482
 483  lock $plan if THREADSAFE;
 484
 485  my $bail_out_str = 'Bail out!';
 486  if (defined $desc) {
 487   sanitize_comment($desc);
 488   $bail_out_str  .= "  $desc" if length $desc; # Two spaces
 489  }
 490
 491  local $\;
 492  print $TAP_STREAM "$bail_out_str\n";
 493
 494  exit 255;
 495 }
 496
 497 END {
 498  unless ($?) {
 499   lock $plan if THREADSAFE;
 500
 501   if (defined $plan) {
 502    if ($failed) {
 503     $? = $failed <= 254 ? $failed : 254;
 504    } elsif ($plan >= 0) {
 505     $? = $test == $plan ? 0 : 255;
 506    } elsif ($plan == NO_PLAN) {
 507     local $\;
 508     print $TAP_STREAM "1..$test\n";
 509    }
 510   }
 511  }
 512 }
 513
 514 =pod
 515
 516 L<Test::Leaner> also provides some functions of its own, which are never exported.
 517
 518 =head2 C<tap_stream [ $fh ]>
 519
 520 Read/write accessor for the filehandle to which the tests are outputted.
 521 On write, it also turns autoflush on onto C<$fh>.
 522
 523 Note that it can only be used as a write accessor before you start any thread, as L<threads::shared> cannot reliably share filehandles.
 524
 525 Defaults to C<STDOUT>.
 526
 527 =cut
 528
 529 sub tap_stream (;*) {
 530  if (@_) {
 531   $TAP_STREAM = $_[0];
 532
 533   my $fh = select $TAP_STREAM;
 534   $|++;
 535   select $fh;
 536  }
 537
 538  return $TAP_STREAM;
 539 }
 540
 541 tap_stream *STDOUT;
 542
 543 =head2 C<diag_stream [ $fh ]>
 544
 545 Read/write accessor for the filehandle to which the diagnostics are printed.
 546 On write, it also turns autoflush on onto C<$fh>.
 547
 548 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.
 549
 550 Defaults to C<STDERR>.
 551
 552 =cut
 553
 554 sub diag_stream (;*) {
 555  if (@_) {
 556   $DIAG_STREAM = $_[0];
 557
 558   my $fh = select $DIAG_STREAM;
 559   $|++;
 560   select $fh;
 561  }
 562
 563  return $DIAG_STREAM;
 564 }
 565
 566 diag_stream *STDERR;
 567
 568 =head1 DEPENDENCIES
 569
 570 L<perl> 5.6.
 571
 572 L<Exporter>, L<Test::More>
 573
 574 =head1 AUTHOR
 575
 576 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
 577
 578 You can contact me by mail or on C<irc.perl.org> (vincent).
 579
 580 =head1 BUGS
 581
 582 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>.
 583 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
 584
 585 =head1 SUPPORT
 586
 587 You can find documentation for this module with the perldoc command.
 588
 589     perldoc Test::Leaner
 590
 591 =head1 COPYRIGHT & LICENSE
 592
 593 Copyright 2010 Vincent Pit, all rights reserved.
 594
 595 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
 596
 597 =cut
 598
 599 1; # End of Test::Leaner