package Test::Leaner;

use 5.006;
use strict;
use warnings;

our $VERSION = '0.01';

use Exporter ();

BEGIN {
 if ($] >= 5.008 and $INC{'threads.pm'}) {
  my $use_ithreads = do {
   require Config;
   no warnings 'once';
   $Config::Config{useithreads};
  };
  if ($use_ithreads) {
   require threads::shared;
   *THREADSAFE = sub () { 1 };
  }
 }
 unless (defined &Test::Leaner::THREADSAFE) {
  *THREADSAFE = sub () { 0 }
 }
}

my ($plan, $test, $failed, $no_diag);

sub NO_PLAN  () { -1 }
sub SKIP_ALL () { -2 }

BEGIN {
 threads::shared::share($plan), lock $plan if THREADSAFE;

 $plan   = undef;
 $test   = 0;
 $failed = 0;
}

my $TAP_STREAM  = *STDOUT;
my $DIAG_STREAM = *STDERR;

sub carp {
 my $level = 1 + ($Test::Builder::Level || 0);
 my ($file, $line) = (caller $level)[1, 2];
 warn @_, " at $file line $line.\n";
}

sub croak {
 my $level = 1 + ($Test::Builder::Level || 0);
 my ($file, $line) = (caller $level)[1, 2];
 die @_, " at $file line $line.\n";
}

sub sanitize_comment {
 $_[0] =~ s/\n+\z//;
 $_[0] =~ s/#/\\#/g;
 $_[0] =~ s/\n/\n# /g;
}

sub plan {
 my ($key, $value) = @_;

 return unless $key;

 lock $plan if THREADSAFE;

 croak("You tried to plan twice") if defined $plan;

 my $plan_str;

 if ($key eq 'no_plan') {
  croak("no_plan takes no arguments") if $value;
  $plan       = NO_PLAN;
 } elsif ($key eq 'tests') {
  croak("Got an undefined number of tests") unless defined $value;
  croak("You said to run 0 tests")          unless $value;
  croak("Number of tests must be a positive integer.  You gave it '$value'")
                                            unless $value =~ /^\+?[0-9]+$/;
  $plan       = $value;
  $plan_str   = "1..$value";
 } elsif ($key eq 'skip_all') {
  $plan       = SKIP_ALL;
  $plan_str   = '1..0 # SKIP';
  if (defined $value) {
   sanitize_comment($value);
   $plan_str .= " $value" if length $value;
  }
 } else {
  my @args = grep defined, $key, $value;
  croak("plan() doesn't understand @args");
 }

 {
  my $fh = select $TAP_STREAM;
  $|++;
  select $fh;
 }

 if (defined $plan_str) {
  local $\;
  print $TAP_STREAM "$plan_str\n";
 }

 exit 0 if $plan == SKIP_ALL;

 return 1;
}

our @EXPORT = qw<
 plan
 skip_all
 skip
 done_testing
 pass
 fail
 ok
 is
 isnt
 like
 unlike
 diag
 note
 BAIL_OUT
>;

sub import {
 my $class = shift;

 my @imports;
 my $i = 0;
 while ($i <= $#_) {
  my $item = $_[$i];
  my $splice;
  if (defined $item) {
   if ($item eq 'import') {
    push @imports, @{ $_[$i+1] };
    $splice  = 2;
   } elsif ($item eq 'no_diag') {
    $no_diag = 1;
    $splice  = 1;
   }
  }
  if ($splice) {
   splice @_, $i, $splice;
  } else {
   ++$i;
  }
 }

 if (@_) {
  local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
  &plan;
 }

 @_ = ($class, @imports);
 goto &Exporter::import;
}

sub skip_all {
 @_ = (skip_all => $_[0]);
 goto &plan;
}

sub skip {
 my ($reason, $count) = @_;

 lock $plan if THREADSAFE;

 if (not defined $count) {
  carp("skip() needs to know \$how_many tests are in the block")
                                      unless defined $plan and $plan == NO_PLAN;
  $count = 1;
 } elsif ($count =~ /[^0-9]/) {
  carp('skip() was passed a non-numeric number of tests.  Did you get the arguments backwards?');
  $count = 1;
 }

 for (1 .. $count) {
  my $skip_str = "ok $test # skip";
  if (defined $reason) {
   sanitize_comment($reason);
   $skip_str  .= " $reason" if length $reason;
  }

  local $\;
  print $TAP_STREAM "$skip_str\n";

  $test++;
 }

 no warnings 'exiting';
 last SKIP;
}

my $done_testing;

sub done_testing {
 my ($count) = @_;

 lock $plan if THREADSAFE;

 $count = $test unless defined $count;
 croak("Number of tests must be a positive integer.  You gave it '$count'")
                                                 unless $count =~ /^\+?[0-9]+$/;

 if (not defined $plan or $plan == NO_PLAN) {
  $plan         = $count; # $plan can't be NO_PLAN anymore
  $done_testing = 1;
  local $\;
  print $TAP_STREAM "1..$plan\n";
 } else {
  if ($done_testing) {
   @_ = ('done_testing() was already called');
   goto &fail;
  } elsif ($plan != $count) {
   @_ = ("planned to run $plan tests but done_testing() expects $count");
   goto &fail;
  }
 }

 return 1;
}

sub ok ($;$) {
 my ($ok, $desc) = @_;

 lock $plan if THREADSAFE;

 ++$test;

 my $test_str = "ok $test";
 unless ($ok) {
  $test_str   = "not $test_str";
  ++$failed;
 }
 if (defined $desc) {
  sanitize_comment($desc);
  $test_str .= " - $desc" if length $desc;
 }

 local $\;
 print $TAP_STREAM "$test_str\n";

 return $ok;
}

sub pass (;$) {
 unshift @_, 1;
 goto &ok;
}

sub fail (;$) {
 unshift @_, 0;
 goto &ok;
}

my %binops;
BEGIN {
 %binops = (
  'or'  => 'or',
  'and' => 'and',
  'xor' => 'xor',

  '||'  => 'hor',
  '&&'  => 'hand',

  'lt'  => 'lt',
  'le'  => 'le',
  'gt'  => 'gt',
  'ge'  => 'ge',
  'eq'  => 'eq',
  'ne'  => 'ne',
  'cmp' => 'cmp',

  '<'   => 'nlt',
  '<='  => 'nle',
  '>'   => 'ngt',
  '>='  => 'nge',
  '=='  => 'neq',
  '!='  => 'nne',
  '<=>' => 'ncmp',

  '=~'  => 'like',
  '!~'  => 'unlike',
  '~~'  => 'smartmatch',
 );

 for my $op (sort keys %binops) {
  my $name = $binops{$op};
  local $@;
  eval <<"IS_BINOP";
sub is_$name (\$\$;\$) {
 my (\$x, \$y, \$desc) = \@_;
 no warnings 'uninitialized';
 \@_ = (
  (not(defined \$x xor defined \$y) and \$x $op \$y),
  \$desc,
 );
 goto &ok;
}
IS_BINOP
  die $@ if $@;
 }
}

{
 no warnings 'once';
 *is     = \&is_eq;
 *like   = \&is_like;
 *unlike = \&is_unlike;
}

sub isnt ($$;$) {
 my ($x, $y, $desc) = @_;
 no warnings 'uninitialized';
 @_ = (
  ((defined $x xor defined $y) or $x ne $y),
  $desc,
 );
 goto &ok;
}

sub cmp_ok ($$$;$) {
 my ($x, $op, $y, $desc) = @_;
 my $name = $binops{$op};
 croak("Operator $op not supported") unless defined $name;
 @_ = ($x, $y, $desc);
 no strict 'refs';
 goto &{__PACKAGE__."is_$name"};
}

sub _diag_fh {
 my $fh = shift;

 return unless @_;

 lock $plan if THREADSAFE;
 return if $no_diag;

 my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
 sanitize_comment($msg);
 return unless length $msg;

 local $\;
 print $fh "# $msg\n";

 return 0;
};

sub diag {
 unshift @_, $DIAG_STREAM;
 goto &_diag_fh;
}

sub note {
 unshift @_, $TAP_STREAM;
 goto &_diag_fh;
}

sub BAIL_OUT {
 my ($desc) = @_;

 lock $plan if THREADSAFE;

 my $bail_out_str = 'Bail out!';
 if (defined $desc) {
  sanitize_comment($desc);
  $bail_out_str  .= "  $desc" if length $desc; # Two spaces
 }

 local $\;
 print $TAP_STREAM "$bail_out_str\n";

 exit 255;
}

END {
 unless ($?) {
  lock $plan if THREADSAFE;

  if (defined $plan) {
   if ($failed) {
    $? = $failed <= 254 ? $failed : 254;
   } elsif ($plan >= 0) {
    $? = $test == $plan ? 0 : 255;
   } elsif ($plan == NO_PLAN) {
    local $\;
    print $TAP_STREAM "1..$test\n";
   }
  }
 }
}

1; # End of Test::Leaner
