lib/Test/Leaner.pm

   1 package Test::Leaner;
   2
   3 use 5.006;
   4 use strict;
   5 use warnings;
   6
   7 our $VERSION = '0.01';
   8
   9 use Exporter ();
  10
  11 BEGIN {
  12  if ($] >= 5.008 and $INC{'threads.pm'}) {
  13   my $use_ithreads = do {
  14    require Config;
  15    no warnings 'once';
  16    $Config::Config{useithreads};
  17   };
  18   if ($use_ithreads) {
  19    require threads::shared;
  20    *THREADSAFE = sub () { 1 };
  21   }
  22  }
  23  unless (defined &Test::Leaner::THREADSAFE) {
  24   *THREADSAFE = sub () { 0 }
  25  }
  26 }
  27
  28 my $TAP_STREAM  = *STDOUT;
  29 my $DIAG_STREAM = *STDERR;
  30
  31 for ($TAP_STREAM, $DIAG_STREAM) {
  32  my $fh = select $_;
  33  $|++;
  34  select $fh;
  35 }
  36
  37 my ($plan, $test, $failed, $no_diag, $done_testing);
  38
  39 sub NO_PLAN  () { -1 }
  40 sub SKIP_ALL () { -2 }
  41
  42 BEGIN {
  43  if (THREADSAFE) {
  44   threads::shared::share($_) for $plan, $test, $failed, $no_diag, $done_testing;
  45  }
  46
  47  lock $plan if THREADSAFE;
  48
  49  $plan   = undef;
  50  $test   = 0;
  51  $failed = 0;
  52 }
  53
  54 sub carp {
  55  my $level = 1 + ($Test::Builder::Level || 0);
  56  my ($file, $line) = (caller $level)[1, 2];
  57  warn @_, " at $file line $line.\n";
  58 }
  59
  60 sub croak {
  61  my $level = 1 + ($Test::Builder::Level || 0);
  62  my ($file, $line) = (caller $level)[1, 2];
  63  die @_, " at $file line $line.\n";
  64 }
  65
  66 sub sanitize_comment {
  67  $_[0] =~ s/\n+\z//;
  68  $_[0] =~ s/#/\\#/g;
  69  $_[0] =~ s/\n/\n# /g;
  70 }
  71
  72 sub plan {
  73  my ($key, $value) = @_;
  74
  75  return unless $key;
  76
  77  lock $plan if THREADSAFE;
  78
  79  croak("You tried to plan twice") if defined $plan;
  80
  81  my $plan_str;
  82
  83  if ($key eq 'no_plan') {
  84   croak("no_plan takes no arguments") if $value;
  85   $plan       = NO_PLAN;
  86  } elsif ($key eq 'tests') {
  87   croak("Got an undefined number of tests") unless defined $value;
  88   croak("You said to run 0 tests")          unless $value;
  89   croak("Number of tests must be a positive integer.  You gave it '$value'")
  90                                             unless $value =~ /^\+?[0-9]+$/;
  91   $plan       = $value;
  92   $plan_str   = "1..$value";
  93  } elsif ($key eq 'skip_all') {
  94   $plan       = SKIP_ALL;
  95   $plan_str   = '1..0 # SKIP';
  96   if (defined $value) {
  97    sanitize_comment($value);
  98    $plan_str .= " $value" if length $value;
  99   }
 100  } else {
 101   my @args = grep defined, $key, $value;
 102   croak("plan() doesn't understand @args");
 103  }
 104
 105  if (defined $plan_str) {
 106   local $\;
 107   print $TAP_STREAM "$plan_str\n";
 108  }
 109
 110  exit 0 if $plan == SKIP_ALL;
 111
 112  return 1;
 113 }
 114
 115 our @EXPORT = qw<
 116  plan
 117  skip_all
 118  skip
 119  done_testing
 120  pass
 121  fail
 122  ok
 123  is
 124  isnt
 125  cmp_ok
 126  like
 127  unlike
 128  diag
 129  note
 130  BAIL_OUT
 131 >;
 132
 133 sub import {
 134  my $class = shift;
 135
 136  my @imports;
 137  my $i = 0;
 138  while ($i <= $#_) {
 139   my $item = $_[$i];
 140   my $splice;
 141   if (defined $item) {
 142    if ($item eq 'import') {
 143     push @imports, @{ $_[$i+1] };
 144     $splice  = 2;
 145    } elsif ($item eq 'no_diag') {
 146     lock $plan if THREADSAFE;
 147     $no_diag = 1;
 148     $splice  = 1;
 149    }
 150   }
 151   if ($splice) {
 152    splice @_, $i, $splice;
 153   } else {
 154    ++$i;
 155   }
 156  }
 157
 158  if (@_) {
 159   local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
 160   &plan;
 161  }
 162
 163  @_ = ($class, @imports);
 164  goto &Exporter::import;
 165 }
 166
 167 sub skip_all {
 168  @_ = (skip_all => $_[0]);
 169  goto &plan;
 170 }
 171
 172 sub skip {
 173  my ($reason, $count) = @_;
 174
 175  lock $plan if THREADSAFE;
 176
 177  if (not defined $count) {
 178   carp("skip() needs to know \$how_many tests are in the block")
 179                                       unless defined $plan and $plan == NO_PLAN;
 180   $count = 1;
 181  } elsif ($count =~ /[^0-9]/) {
 182   carp('skip() was passed a non-numeric number of tests.  Did you get the arguments backwards?');
 183   $count = 1;
 184  }
 185
 186  for (1 .. $count) {
 187   ++$test;
 188
 189   my $skip_str = "ok $test # skip";
 190   if (defined $reason) {
 191    sanitize_comment($reason);
 192    $skip_str  .= " $reason" if length $reason;
 193   }
 194
 195   local $\;
 196   print $TAP_STREAM "$skip_str\n";
 197  }
 198
 199  no warnings 'exiting';
 200  last SKIP;
 201 }
 202
 203 sub done_testing {
 204  my ($count) = @_;
 205
 206  lock $plan if THREADSAFE;
 207
 208  $count = $test unless defined $count;
 209  croak("Number of tests must be a positive integer.  You gave it '$count'")
 210                                                  unless $count =~ /^\+?[0-9]+$/;
 211
 212  if (not defined $plan or $plan == NO_PLAN) {
 213   $plan         = $count; # $plan can't be NO_PLAN anymore
 214   $done_testing = 1;
 215   local $\;
 216   print $TAP_STREAM "1..$plan\n";
 217  } else {
 218   if ($done_testing) {
 219    @_ = ('done_testing() was already called');
 220    goto &fail;
 221   } elsif ($plan != $count) {
 222    @_ = ("planned to run $plan tests but done_testing() expects $count");
 223    goto &fail;
 224   }
 225  }
 226
 227  return 1;
 228 }
 229
 230 sub ok ($;$) {
 231  my ($ok, $desc) = @_;
 232
 233  lock $plan if THREADSAFE;
 234
 235  ++$test;
 236
 237  my $test_str = "ok $test";
 238  unless ($ok) {
 239   $test_str   = "not $test_str";
 240   ++$failed;
 241  }
 242  if (defined $desc) {
 243   sanitize_comment($desc);
 244   $test_str .= " - $desc" if length $desc;
 245  }
 246
 247  local $\;
 248  print $TAP_STREAM "$test_str\n";
 249
 250  return $ok;
 251 }
 252
 253 sub pass (;$) {
 254  unshift @_, 1;
 255  goto &ok;
 256 }
 257
 258 sub fail (;$) {
 259  unshift @_, 0;
 260  goto &ok;
 261 }
 262
 263 sub is ($$;$) {
 264  my ($got, $expected, $desc) = @_;
 265  no warnings 'uninitialized';
 266  @_ = (
 267   (not(defined $got xor defined $expected) and $got eq $expected),
 268   $desc,
 269  );
 270  goto &ok;
 271 }
 272
 273 sub isnt ($$;$) {
 274  my ($got, $expected, $desc) = @_;
 275  no warnings 'uninitialized';
 276  @_ = (
 277   ((defined $got xor defined $expected) or $got ne $expected),
 278   $desc,
 279  );
 280  goto &ok;
 281 }
 282
 283 my %binops = (
 284  'or'  => 'or',
 285  'and' => 'and',
 286  'xor' => 'xor',
 287
 288  '||'  => 'hor',
 289  '&&'  => 'hand',
 290
 291  'lt'  => 'lt',
 292  'le'  => 'le',
 293  'gt'  => 'gt',
 294  'ge'  => 'ge',
 295  'eq'  => 'eq',
 296  'ne'  => 'ne',
 297  'cmp' => 'cmp',
 298
 299  '<'   => 'nlt',
 300  '<='  => 'nle',
 301  '>'   => 'ngt',
 302  '>='  => 'nge',
 303  '=='  => 'neq',
 304  '!='  => 'nne',
 305  '<=>' => 'ncmp',
 306
 307  '=~'  => 'like',
 308  '!~'  => 'unlike',
 309  '~~'  => 'smartmatch',
 310 );
 311
 312 my %binop_handlers;
 313
 314 sub _create_binop_handler {
 315  my ($op) = @_;
 316  my $name = $binops{$op};
 317  croak("Operator $op not supported") unless defined $name;
 318  {
 319   local $@;
 320   eval <<"IS_BINOP";
 321 sub is_$name (\$\$;\$) {
 322  my (\$got, \$expected, \$desc) = \@_;
 323  \@_ = ((\$got $op \$expected), \$desc);
 324  goto &ok;
 325 }
 326 IS_BINOP
 327   die $@ if $@;
 328  }
 329  $binop_handlers{$op} = do {
 330   no strict 'refs';
 331   \&{__PACKAGE__."::is_$name"};
 332  }
 333 }
 334
 335 {
 336  no warnings 'once';
 337  *like   = _create_binop_handler('=~');
 338  *unlike = _create_binop_handler('!~');
 339 }
 340
 341 sub cmp_ok ($$$;$) {
 342  my ($got, $op, $expected, $desc) = @_;
 343  my $handler = $binop_handlers{$op};
 344  unless ($handler) {
 345   local $Test::More::Level = ($Test::More::Level || 0) + 1;
 346   $handler = _create_binop_handler($op);
 347  }
 348  @_ = ($got, $expected, $desc);
 349  goto $handler;
 350 }
 351
 352 sub _diag_fh {
 353  my $fh = shift;
 354
 355  return unless @_;
 356
 357  lock $plan if THREADSAFE;
 358  return if $no_diag;
 359
 360  my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
 361  sanitize_comment($msg);
 362  return unless length $msg;
 363
 364  local $\;
 365  print $fh "# $msg\n";
 366
 367  return 0;
 368 };
 369
 370 sub diag {
 371  unshift @_, $DIAG_STREAM;
 372  goto &_diag_fh;
 373 }
 374
 375 sub note {
 376  unshift @_, $TAP_STREAM;
 377  goto &_diag_fh;
 378 }
 379
 380 sub BAIL_OUT {
 381  my ($desc) = @_;
 382
 383  lock $plan if THREADSAFE;
 384
 385  my $bail_out_str = 'Bail out!';
 386  if (defined $desc) {
 387   sanitize_comment($desc);
 388   $bail_out_str  .= "  $desc" if length $desc; # Two spaces
 389  }
 390
 391  local $\;
 392  print $TAP_STREAM "$bail_out_str\n";
 393
 394  exit 255;
 395 }
 396
 397 END {
 398  unless ($?) {
 399   lock $plan if THREADSAFE;
 400
 401   if (defined $plan) {
 402    if ($failed) {
 403     $? = $failed <= 254 ? $failed : 254;
 404    } elsif ($plan >= 0) {
 405     $? = $test == $plan ? 0 : 255;
 406    } elsif ($plan == NO_PLAN) {
 407     local $\;
 408     print $TAP_STREAM "1..$test\n";
 409    }
 410   }
 411  }
 412 }
 413
 414 1; # End of Test::Leaner