X-Git-Url: http://git.vpit.fr/?a=blobdiff_plain;f=lib%2FTest%2FLeaner.pm;h=1efe7a295183bf1f285b059b82cc57fe635c9b24;hb=e3217cb5d83d1ae15f1795bef7c885740607689b;hp=f0f490eba2ed5f9930d44a8d7de7c5f10c5b15dd;hpb=41367a04c268486fb815420a103f80e28ffefd63;p=perl%2Fmodules%2FTest-Leaner.git

diff --git a/lib/Test/Leaner.pm b/lib/Test/Leaner.pm
index f0f490e..1efe7a2 100644
--- a/lib/Test/Leaner.pm
+++ b/lib/Test/Leaner.pm
@@ -25,22 +25,32 @@ BEGIN {
  }
 }
 
-my ($plan, $test, $failed, $no_diag);
+my $TAP_STREAM  = *STDOUT;
+my $DIAG_STREAM = *STDERR;
+
+for ($TAP_STREAM, $DIAG_STREAM) {
+ my $fh = select $_;
+ $|++;
+ select $fh;
+}
+
+my ($plan, $test, $failed, $no_diag, $done_testing);
 
 sub NO_PLAN  () { -1 }
 sub SKIP_ALL () { -2 }
 
 BEGIN {
- threads::shared::share($plan), lock $plan if THREADSAFE;
+ if (THREADSAFE) {
+  threads::shared::share($_) for $plan, $test, $failed, $no_diag, $done_testing;
+ }
+
+ 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];
@@ -92,12 +102,6 @@ sub plan {
   croak("plan() doesn't understand @args");
  }
 
- {
-  my $fh = select $TAP_STREAM;
-  $|++;
-  select $fh;
- }
-
  if (defined $plan_str) {
   local $\;
   print $TAP_STREAM "$plan_str\n";
@@ -118,6 +122,7 @@ our @EXPORT = qw<
  ok
  is
  isnt
+ cmp_ok
  like
  unlike
  diag
@@ -138,6 +143,7 @@ sub import {
     push @imports, @{ $_[$i+1] };
     $splice  = 2;
    } elsif ($item eq 'no_diag') {
+    lock $plan if THREADSAFE;
     $no_diag = 1;
     $splice  = 1;
    }
@@ -178,6 +184,8 @@ sub skip {
  }
 
  for (1 .. $count) {
+  ++$test;
+
   my $skip_str = "ok $test # skip";
   if (defined $reason) {
    sanitize_comment($reason);
@@ -186,16 +194,12 @@ sub skip {
 
   local $\;
   print $TAP_STREAM "$skip_str\n";
-
-  $test++;
  }
 
  no warnings 'exiting';
  last SKIP;
 }
 
-my $done_testing;
-
 sub done_testing {
  my ($count) = @_;
 
@@ -256,79 +260,93 @@ sub fail (;$) {
  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',
+sub is ($$;$) {
+ my ($got, $expected, $desc) = @_;
+ no warnings 'uninitialized';
+ @_ = (
+  (not(defined $got xor defined $expected) and $got eq $expected),
+  $desc,
+ );
+ goto &ok;
+}
+
+sub isnt ($$;$) {
+ my ($got, $expected, $desc) = @_;
+ no warnings 'uninitialized';
+ @_ = (
+  ((defined $got xor defined $expected) or $got ne $expected),
+  $desc,
  );
+ goto &ok;
+}
 
- for my $op (sort keys %binops) {
-  my $name = $binops{$op};
+my %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',
+);
+
+my %binop_handlers;
+
+sub _create_binop_handler {
+ my ($op) = @_;
+ my $name = $binops{$op};
+ croak("Operator $op not supported") unless defined $name;
+ {
   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,
- );
+ my (\$got, \$expected, \$desc) = \@_;
+ \@_ = ((\$got $op \$expected), \$desc);
  goto &ok;
 }
 IS_BINOP
   die $@ if $@;
  }
+ $binop_handlers{$op} = do {
+  no strict 'refs';
+  \&{__PACKAGE__."::is_$name"};
+ }
 }
 
 {
  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;
+ *like   = _create_binop_handler('=~');
+ *unlike = _create_binop_handler('!~');
 }
 
 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"};
+ my ($got, $op, $expected, $desc) = @_;
+ my $handler = $binop_handlers{$op};
+ unless ($handler) {
+  local $Test::More::Level = ($Test::More::Level || 0) + 1;
+  $handler = _create_binop_handler($op);
+ }
+ @_ = ($got, $expected, $desc);
+ goto $handler;
 }
 
 sub _diag_fh {