]> git.vpit.fr Git - perl/modules/Test-Leaner.git/blob - lib/Test/Leaner.pm
Add pointers to the original documentation from Test::More
[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 =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> and L</is_deeply> honor C<'eq'> overloading (and just that one) 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 L</like> and L</unlike> don't special case regular expressions that are passed as C<'/.../'> strings.
49 A string regexp argument is always treated as a the source of the regexp, making C<like $text, $rx> and C<like $text, qr[$rx]> equivalent to each other and to C<cmp_ok $text, '=~', $rx> (and likewise for C<unlike>).
50
51 =item *
52
53 L</cmp_ok> throws an exception if the given operator isn't a valid Perl binary operator (except C<'='> and variants).
54 It also tests in scalar context, so C<'..'> will be treated as the flip-flop operator and not the range operator.
55
56 =item *
57
58 L</is_deeply> doesn't guard for memory cycles.
59 If the two first arguments present parallel memory cycles, the test may result in an infinite loop.
60
61 =item *
62
63 The tests don't output any kind of default diagnostic in case of failure ; the rationale being that if you have a large number of tests and a lot of them are failing, then you don't want to be flooded by diagnostics.
64
65 =item *
66
67 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.
68
69 =item *
70
71 L<Test::Leaner> depends on L<Scalar::Util>, while L<Test::More> does not.
72
73 =back
74
75 =cut
76
77 use Exporter     ();
78 use Scalar::Util ();
79
80 BEGIN {
81  if ($] >= 5.008 and $INC{'threads.pm'}) {
82   my $use_ithreads = do {
83    require Config;
84    no warnings 'once';
85    $Config::Config{useithreads};
86   };
87   if ($use_ithreads) {
88    require threads::shared;
89    *THREADSAFE = sub () { 1 };
90   }
91  }
92  unless (defined &Test::Leaner::THREADSAFE) {
93   *THREADSAFE = sub () { 0 }
94  }
95 }
96
97 my ($TAP_STREAM, $DIAG_STREAM);
98
99 my ($plan, $test, $failed, $no_diag, $done_testing);
100
101 sub NO_PLAN  () { -1 }
102 sub SKIP_ALL () { -2 }
103
104 BEGIN {
105  if (THREADSAFE) {
106   threads::shared::share($_) for $plan, $test, $failed, $no_diag, $done_testing;
107  }
108
109  lock $plan if THREADSAFE;
110
111  $plan   = undef;
112  $test   = 0;
113  $failed = 0;
114 }
115
116 sub carp {
117  my $level = 1 + ($Test::Builder::Level || 0);
118  my ($file, $line) = (caller $level)[1, 2];
119  warn @_, " at $file line $line.\n";
120 }
121
122 sub croak {
123  my $level = 1 + ($Test::Builder::Level || 0);
124  my ($file, $line) = (caller $level)[1, 2];
125  die @_, " at $file line $line.\n";
126 }
127
128 sub _sanitize_comment {
129  $_[0] =~ s/\n+\z//;
130  $_[0] =~ s/#/\\#/g;
131  $_[0] =~ s/\n/\n# /g;
132 }
133
134 =head1 FUNCTIONS
135
136 The following functions from L<Test::More> are implemented and exported by default.
137
138 =head2 C<< plan [ tests => $count | 'no_plan' | skip_all => $reason ] >>
139
140 See L<Test::More/plan>.
141
142 =cut
143
144 sub plan {
145  my ($key, $value) = @_;
146
147  return unless $key;
148
149  lock $plan if THREADSAFE;
150
151  croak("You tried to plan twice") if defined $plan;
152
153  my $plan_str;
154
155  if ($key eq 'no_plan') {
156   croak("no_plan takes no arguments") if $value;
157   $plan       = NO_PLAN;
158  } elsif ($key eq 'tests') {
159   croak("Got an undefined number of tests") unless defined $value;
160   croak("You said to run 0 tests")          unless $value;
161   croak("Number of tests must be a positive integer.  You gave it '$value'")
162                                             unless $value =~ /^\+?[0-9]+$/;
163   $plan       = $value;
164   $plan_str   = "1..$value";
165  } elsif ($key eq 'skip_all') {
166   $plan       = SKIP_ALL;
167   $plan_str   = '1..0 # SKIP';
168   if (defined $value) {
169    _sanitize_comment($value);
170    $plan_str .= " $value" if length $value;
171   }
172  } else {
173   my @args = grep defined, $key, $value;
174   croak("plan() doesn't understand @args");
175  }
176
177  if (defined $plan_str) {
178   local $\;
179   print $TAP_STREAM "$plan_str\n";
180  }
181
182  exit 0 if $plan == SKIP_ALL;
183
184  return 1;
185 }
186
187 our @EXPORT = qw<
188  plan
189  skip
190  done_testing
191  pass
192  fail
193  ok
194  is
195  isnt
196  like
197  unlike
198  cmp_ok
199  is_deeply
200  diag
201  note
202  BAIL_OUT
203 >;
204
205 sub import {
206  my $class = shift;
207
208  my @imports;
209  my $i = 0;
210  while ($i <= $#_) {
211   my $item = $_[$i];
212   my $splice;
213   if (defined $item) {
214    if ($item eq 'import') {
215     push @imports, @{ $_[$i+1] };
216     $splice  = 2;
217    } elsif ($item eq 'no_diag') {
218     lock $plan if THREADSAFE;
219     $no_diag = 1;
220     $splice  = 1;
221    }
222   }
223   if ($splice) {
224    splice @_, $i, $splice;
225   } else {
226    ++$i;
227   }
228  }
229
230  if (@_) {
231   local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
232   &plan;
233  }
234
235  @_ = ($class, @imports);
236  goto &Exporter::import;
237 }
238
239 =head2 C<< skip $reason => $count >>
240
241 See L<Test::More/skip>.
242
243 =cut
244
245 sub skip {
246  my ($reason, $count) = @_;
247
248  lock $plan if THREADSAFE;
249
250  if (not defined $count) {
251   carp("skip() needs to know \$how_many tests are in the block")
252                                       unless defined $plan and $plan == NO_PLAN;
253   $count = 1;
254  } elsif ($count =~ /[^0-9]/) {
255   carp('skip() was passed a non-numeric number of tests.  Did you get the arguments backwards?');
256   $count = 1;
257  }
258
259  for (1 .. $count) {
260   ++$test;
261
262   my $skip_str = "ok $test # skip";
263   if (defined $reason) {
264    _sanitize_comment($reason);
265    $skip_str  .= " $reason" if length $reason;
266   }
267
268   local $\;
269   print $TAP_STREAM "$skip_str\n";
270  }
271
272  no warnings 'exiting';
273  last SKIP;
274 }
275
276 =head2 C<done_testing [ $count ]>
277
278 See L<Test::More/done_testing>.
279
280 =cut
281
282 sub done_testing {
283  my ($count) = @_;
284
285  lock $plan if THREADSAFE;
286
287  $count = $test unless defined $count;
288  croak("Number of tests must be a positive integer.  You gave it '$count'")
289                                                  unless $count =~ /^\+?[0-9]+$/;
290
291  if (not defined $plan or $plan == NO_PLAN) {
292   $plan         = $count; # $plan can't be NO_PLAN anymore
293   $done_testing = 1;
294   local $\;
295   print $TAP_STREAM "1..$plan\n";
296  } else {
297   if ($done_testing) {
298    @_ = ('done_testing() was already called');
299    goto &fail;
300   } elsif ($plan != $count) {
301    @_ = ("planned to run $plan tests but done_testing() expects $count");
302    goto &fail;
303   }
304  }
305
306  return 1;
307 }
308
309 =head2 C<ok $ok [, $desc ]>
310
311 See L<Test::More/ok>.
312
313 =cut
314
315 sub ok ($;$) {
316  my ($ok, $desc) = @_;
317
318  lock $plan if THREADSAFE;
319
320  ++$test;
321
322  my $test_str = "ok $test";
323  unless ($ok) {
324   $test_str   = "not $test_str";
325   ++$failed;
326  }
327  if (defined $desc) {
328   _sanitize_comment($desc);
329   $test_str .= " - $desc" if length $desc;
330  }
331
332  local $\;
333  print $TAP_STREAM "$test_str\n";
334
335  return $ok;
336 }
337
338 =head2 C<pass [ $desc ]>
339
340 See L<Test::More/pass>.
341
342 =cut
343
344 sub pass (;$) {
345  unshift @_, 1;
346  goto &ok;
347 }
348
349 =head2 C<fail [ $desc ]>
350
351 See L<Test::More/fail>.
352
353 =cut
354
355 sub fail (;$) {
356  unshift @_, 0;
357  goto &ok;
358 }
359
360 =head2 C<is $got, $expected [, $desc ]>
361
362 See L<Test::More/is>.
363
364 =cut
365
366 sub is ($$;$) {
367  my ($got, $expected, $desc) = @_;
368  no warnings 'uninitialized';
369  @_ = (
370   (not(defined $got xor defined $expected) and $got eq $expected),
371   $desc,
372  );
373  goto &ok;
374 }
375
376 =head2 C<isnt $got, $expected [, $desc ]>
377
378 See L<Test::More/isnt>.
379
380 =cut
381
382 sub isnt ($$;$) {
383  my ($got, $expected, $desc) = @_;
384  no warnings 'uninitialized';
385  @_ = (
386   ((defined $got xor defined $expected) or $got ne $expected),
387   $desc,
388  );
389  goto &ok;
390 }
391
392 my %binops = (
393  'or'  => 'or',
394  'xor' => 'xor',
395  'and' => 'and',
396
397  '||'  => 'hor',
398  ('//' => 'dor') x ($] >= 5.010),
399  '&&'  => 'hand',
400
401  '|'   => 'bor',
402  '^'   => 'bxor',
403  '&'   => 'band',
404
405  'lt'  => 'lt',
406  'le'  => 'le',
407  'gt'  => 'gt',
408  'ge'  => 'ge',
409  'eq'  => 'eq',
410  'ne'  => 'ne',
411  'cmp' => 'cmp',
412
413  '<'   => 'nlt',
414  '<='  => 'nle',
415  '>'   => 'ngt',
416  '>='  => 'nge',
417  '=='  => 'neq',
418  '!='  => 'nne',
419  '<=>' => 'ncmp',
420
421  '=~'  => 'like',
422  '!~'  => 'unlike',
423  ('~~' => 'smartmatch') x ($] >= 5.010),
424
425  '+'   => 'add',
426  '-'   => 'substract',
427  '*'   => 'multiply',
428  '/'   => 'divide',
429  '%'   => 'modulo',
430  '<<'  => 'lshift',
431  '>>'  => 'rshift',
432
433  '.'   => 'concat',
434  '..'  => 'flipflop',
435  '...' => 'altflipflop',
436  ','   => 'comma',
437  '=>'  => 'fatcomma',
438 );
439
440 my %binop_handlers;
441
442 sub _create_binop_handler {
443  my ($op) = @_;
444  my $name = $binops{$op};
445  croak("Operator $op not supported") unless defined $name;
446  {
447   local $@;
448   eval <<"IS_BINOP";
449 sub is_$name (\$\$;\$) {
450  my (\$got, \$expected, \$desc) = \@_;
451  \@_ = (scalar(\$got $op \$expected), \$desc);
452  goto &ok;
453 }
454 IS_BINOP
455   die $@ if $@;
456  }
457  $binop_handlers{$op} = do {
458   no strict 'refs';
459   \&{__PACKAGE__."::is_$name"};
460  }
461 }
462
463 =head2 C<like $got, $regexp_expected [, $desc ]>
464
465 See L<Test::More/like>.
466
467 =head2 C<unlike $got, $regexp_expected, [, $desc ]>
468
469 See L<Test::More/unlike>.
470
471 =cut
472
473 {
474  no warnings 'once';
475  *like   = _create_binop_handler('=~');
476  *unlike = _create_binop_handler('!~');
477 }
478
479 =head2 C<cmp_ok $got, $op, $expected [, $desc ]>
480
481 See L<Test::More/cmp_ok>.
482
483 =cut
484
485 sub cmp_ok ($$$;$) {
486  my ($got, $op, $expected, $desc) = @_;
487  my $handler = $binop_handlers{$op};
488  unless ($handler) {
489   local $Test::More::Level = ($Test::More::Level || 0) + 1;
490   $handler = _create_binop_handler($op);
491  }
492  @_ = ($got, $expected, $desc);
493  goto $handler;
494 }
495
496 =head2 C<is_deeply $got, $expected [, $desc ]>
497
498 See L<Test::More/is_deeply>.
499
500 =cut
501
502 sub _deep_check {
503  my ($x, $y) = @_;
504
505  no warnings qw<numeric uninitialized>;
506
507  return 0 if defined($x) xor defined($y);
508
509  # Try object identity/eq overloading first. It also covers the case where
510  # $x and $y are both undefined.
511  # If either $x or $y is overloaded but none has eq overloading, the test will
512  # break at that point.
513  return 1 if not(ref($x) xor ref($y)) and $x eq $y;
514
515  # Test::More::is_deeply happily breaks encapsulation if the objects aren't
516  # overloaded.
517  my $ry = Scalar::Util::reftype($y);
518  return 0 if Scalar::Util::reftype($x) ne $ry;
519
520  # Shortcut if $x and $y are both not references and failed the previous
521  # $x eq $y test.
522  return 0 unless $ry;
523
524  if ($ry eq 'ARRAY') {
525   if ($#$x == $#$y) {
526    # Prevent vivification of deleted elements by fetching the array values.
527    my ($ex, $ey);
528    _deep_check($ex = $x->[$_], $ey = $y->[$_]) or return 0 for 0 .. $#$y;
529    return 1;
530   }
531  } elsif ($ry eq 'HASH') {
532   if (keys(%$x) == keys(%$y)) {
533    (exists $x->{$_} and _deep_check($x->{$_}, $y->{$_}))
534                                                        or return 0 for keys %$y;
535    return 1;
536   }
537  } elsif ($ry eq 'SCALAR' or $ry eq 'REF') {
538   return _deep_check($$x, $$y);
539  }
540
541  return 0;
542 };
543
544 sub is_deeply {
545  @_ = (
546   &_deep_check,
547   $_[2],
548  );
549  goto &ok;
550 }
551
552 sub _diag_fh {
553  my $fh = shift;
554
555  return unless @_;
556
557  lock $plan if THREADSAFE;
558  return if $no_diag;
559
560  my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
561  _sanitize_comment($msg);
562  return unless length $msg;
563
564  local $\;
565  print $fh "# $msg\n";
566
567  return 0;
568 };
569
570 =head2 C<diag @text>
571
572 See L<Test::More/diag>.
573
574 =cut
575
576 sub diag {
577  unshift @_, $DIAG_STREAM;
578  goto &_diag_fh;
579 }
580
581 =head2 C<note @text>
582
583 See L<Test::More/note>.
584
585 =cut
586
587 sub note {
588  unshift @_, $TAP_STREAM;
589  goto &_diag_fh;
590 }
591
592 =head2 C<BAIL_OUT [ $desc ]>
593
594 See L<Test::More/BAIL_OUT>.
595
596 =cut
597
598 sub BAIL_OUT {
599  my ($desc) = @_;
600
601  lock $plan if THREADSAFE;
602
603  my $bail_out_str = 'Bail out!';
604  if (defined $desc) {
605   _sanitize_comment($desc);
606   $bail_out_str  .= "  $desc" if length $desc; # Two spaces
607  }
608
609  local $\;
610  print $TAP_STREAM "$bail_out_str\n";
611
612  exit 255;
613 }
614
615 END {
616  unless ($?) {
617   lock $plan if THREADSAFE;
618
619   if (defined $plan) {
620    if ($failed) {
621     $? = $failed <= 254 ? $failed : 254;
622    } elsif ($plan >= 0) {
623     $? = $test == $plan ? 0 : 255;
624    } elsif ($plan == NO_PLAN) {
625     local $\;
626     print $TAP_STREAM "1..$test\n";
627    }
628   }
629  }
630 }
631
632 =pod
633
634 L<Test::Leaner> also provides some functions of its own, which are never exported.
635
636 =head2 C<tap_stream [ $fh ]>
637
638 Read/write accessor for the filehandle to which the tests are outputted.
639 On write, it also turns autoflush on onto C<$fh>.
640
641 Note that it can only be used as a write accessor before you start any thread, as L<threads::shared> cannot reliably share filehandles.
642
643 Defaults to C<STDOUT>.
644
645 =cut
646
647 sub tap_stream (;*) {
648  if (@_) {
649   $TAP_STREAM = $_[0];
650
651   my $fh = select $TAP_STREAM;
652   $|++;
653   select $fh;
654  }
655
656  return $TAP_STREAM;
657 }
658
659 tap_stream *STDOUT;
660
661 =head2 C<diag_stream [ $fh ]>
662
663 Read/write accessor for the filehandle to which the diagnostics are printed.
664 On write, it also turns autoflush on onto C<$fh>.
665
666 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.
667
668 Defaults to C<STDERR>.
669
670 =cut
671
672 sub diag_stream (;*) {
673  if (@_) {
674   $DIAG_STREAM = $_[0];
675
676   my $fh = select $DIAG_STREAM;
677   $|++;
678   select $fh;
679  }
680
681  return $DIAG_STREAM;
682 }
683
684 diag_stream *STDERR;
685
686 =head2 C<THREADSAFE>
687
688 This constant evaluates to true if and only if L<Test::Leaner> is thread-safe, i.e. when this version of C<perl> is at least 5.8, has been compiled with C<useithreads> defined, and L<threads> has been loaded B<before> L<Test::Leaner>.
689 In that case, it also needs a working L<threads::shared>.
690
691 =head1 DEPENDENCIES
692
693 L<perl> 5.6.
694
695 L<Exporter>, L<Scalar::Util>, L<Test::More>.
696
697 =head1 AUTHOR
698
699 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
700
701 You can contact me by mail or on C<irc.perl.org> (vincent).
702
703 =head1 BUGS
704
705 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>.
706 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
707
708 =head1 SUPPORT
709
710 You can find documentation for this module with the perldoc command.
711
712     perldoc Test::Leaner
713
714 =head1 COPYRIGHT & LICENSE
715
716 Copyright 2010 Vincent Pit, all rights reserved.
717
718 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
719
720 =cut
721
722 1; # End of Test::Leaner