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