]> git.vpit.fr Git - perl/modules/Scalar-Vec-Util.git/blob - t/lib/Test/Leaner.pm
Run lengthy tests with Test::Leaner
[perl/modules/Scalar-Vec-Util.git] / t / 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.02
14
15 =cut
16
17 our $VERSION = '0.02';
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 =back
70
71 =cut
72
73 use Exporter ();
74
75 my $main_process;
76
77 BEGIN {
78  $main_process = $$;
79
80  if ($] >= 5.008 and $INC{'threads.pm'}) {
81   my $use_ithreads = do {
82    require Config;
83    no warnings 'once';
84    $Config::Config{useithreads};
85   };
86   if ($use_ithreads) {
87    require threads::shared;
88    *THREADSAFE = sub () { 1 };
89   }
90  }
91  unless (defined &Test::Leaner::THREADSAFE) {
92   *THREADSAFE = sub () { 0 }
93  }
94 }
95
96 my ($TAP_STREAM, $DIAG_STREAM);
97
98 my ($plan, $test, $failed, $no_diag, $done_testing);
99
100 our @EXPORT = qw<
101  plan
102  skip
103  done_testing
104  pass
105  fail
106  ok
107  is
108  isnt
109  like
110  unlike
111  cmp_ok
112  is_deeply
113  diag
114  note
115  BAIL_OUT
116 >;
117
118 =head1 ENVIRONMENT
119
120 =head2 C<PERL_TEST_LEANER_USES_TEST_MORE>
121
122 If this environment variable is set, L<Test::Leaner> will replace its functions by those from L<Test::More>.
123 Moreover, the symbols that are imported you C<use Test::Leaner> will be those from L<Test::More>, but you can still only import the symbols originally defined in L<Test::Leaner> (hence the functions from L<Test::More> that are not implemented in L<Test::Leaner> will not be imported).
124 If your version of L<Test::More> is too old and doesn't have some symbols (like L</note> or L</done_testing>), they will be replaced in L<Test::Leaner> by croaking stubs.
125
126 This may be useful if your L<Test::Leaner>-based test script fails and you want extra diagnostics.
127
128 =cut
129
130 sub _handle_import_args {
131  my @imports;
132
133  my $i = 0;
134  while ($i <= $#_) {
135   my $item = $_[$i];
136   my $splice;
137   if (defined $item) {
138    if ($item eq 'import') {
139     push @imports, @{ $_[$i+1] };
140     $splice  = 2;
141    } elsif ($item eq 'no_diag') {
142     lock $plan if THREADSAFE;
143     $no_diag = 1;
144     $splice  = 1;
145    }
146   }
147   if ($splice) {
148    splice @_, $i, $splice;
149   } else {
150    ++$i;
151   }
152  }
153
154  return @imports;
155 }
156
157 if ($ENV{PERL_TEST_LEANER_USES_TEST_MORE}) {
158  require Test::More;
159
160  my $leaner_stash = \%Test::Leaner::;
161  my $more_stash   = \%Test::More::;
162
163  my %valid_imports;
164
165  for (@EXPORT) {
166   my $replacement = exists $more_stash->{$_} ? *{$more_stash->{$_}}{CODE}
167                                              : undef;
168   if (defined $replacement) {
169    $valid_imports{$_} = 1;
170   } else {
171    $replacement = sub {
172     @_ = ("$_ is not implemented in this version of Test::More");
173     goto &croak;
174    };
175   }
176   no warnings 'redefine';
177   $leaner_stash->{$_} = $replacement;
178  }
179
180  my $import = sub {
181   shift;
182   my @imports = &_handle_import_args;
183   @imports = @EXPORT unless @imports;
184   my @test_more_imports;
185   for (@imports) {
186    if ($valid_imports{$_}) {
187     push @test_more_imports, $_;
188    } else {
189     my $pkg = caller;
190     no strict 'refs';
191     *{$pkg."::$_"} = $leaner_stash->{$_};
192    }
193   }
194   my $test_more_import = 'Test::More'->can('import');
195   @_ = (
196    'Test::More',
197    @_,
198    import => \@test_more_imports,
199   );
200   {
201    lock $plan if THREADSAFE;
202    push @_, 'no_diag' if $no_diag;
203   }
204   goto $test_more_import;
205  };
206
207  no warnings 'redefine';
208  *import = $import;
209
210  return 1;
211 }
212
213 sub NO_PLAN  () { -1 }
214 sub SKIP_ALL () { -2 }
215
216 BEGIN {
217  if (THREADSAFE) {
218   threads::shared::share($_) for $plan, $test, $failed, $no_diag, $done_testing;
219  }
220
221  lock $plan if THREADSAFE;
222
223  $plan   = undef;
224  $test   = 0;
225  $failed = 0;
226 }
227
228 sub carp {
229  my $level = 1 + ($Test::Builder::Level || 0);
230  my @caller;
231  do {
232   @caller = caller $level--;
233  } while (!@caller and $level >= 0);
234  my ($file, $line) = @caller[1, 2];
235  warn @_, " at $file line $line.\n";
236 }
237
238 sub croak {
239  my $level = 1 + ($Test::Builder::Level || 0);
240  my @caller;
241  do {
242   @caller = caller $level--;
243  } while (!@caller and $level >= 0);
244  my ($file, $line) = @caller[1, 2];
245  die @_, " at $file line $line.\n";
246 }
247
248 sub _sanitize_comment {
249  $_[0] =~ s/\n+\z//;
250  $_[0] =~ s/#/\\#/g;
251  $_[0] =~ s/\n/\n# /g;
252 }
253
254 =head1 FUNCTIONS
255
256 The following functions from L<Test::More> are implemented and exported by default.
257
258 =head2 C<< plan [ tests => $count | 'no_plan' | skip_all => $reason ] >>
259
260 See L<Test::More/plan>.
261
262 =cut
263
264 sub plan {
265  my ($key, $value) = @_;
266
267  return unless $key;
268
269  lock $plan if THREADSAFE;
270
271  croak("You tried to plan twice") if defined $plan;
272
273  my $plan_str;
274
275  if ($key eq 'no_plan') {
276   croak("no_plan takes no arguments") if $value;
277   $plan       = NO_PLAN;
278  } elsif ($key eq 'tests') {
279   croak("Got an undefined number of tests") unless defined $value;
280   croak("You said to run 0 tests")          unless $value;
281   croak("Number of tests must be a positive integer.  You gave it '$value'")
282                                             unless $value =~ /^\+?[0-9]+$/;
283   $plan       = $value;
284   $plan_str   = "1..$value";
285  } elsif ($key eq 'skip_all') {
286   $plan       = SKIP_ALL;
287   $plan_str   = '1..0 # SKIP';
288   if (defined $value) {
289    _sanitize_comment($value);
290    $plan_str .= " $value" if length $value;
291   }
292  } else {
293   my @args = grep defined, $key, $value;
294   croak("plan() doesn't understand @args");
295  }
296
297  if (defined $plan_str) {
298   local $\;
299   print $TAP_STREAM "$plan_str\n";
300  }
301
302  exit 0 if $plan == SKIP_ALL;
303
304  return 1;
305 }
306
307 sub import {
308  my $class = shift;
309
310  my @imports = &_handle_import_args;
311
312  if (@_) {
313   local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
314   &plan;
315  }
316
317  @_ = ($class, @imports);
318  goto &Exporter::import;
319 }
320
321 =head2 C<< skip $reason => $count >>
322
323 See L<Test::More/skip>.
324
325 =cut
326
327 sub skip {
328  my ($reason, $count) = @_;
329
330  lock $plan if THREADSAFE;
331
332  if (not defined $count) {
333   carp("skip() needs to know \$how_many tests are in the block")
334                                       unless defined $plan and $plan == NO_PLAN;
335   $count = 1;
336  } elsif ($count =~ /[^0-9]/) {
337   carp('skip() was passed a non-numeric number of tests.  Did you get the arguments backwards?');
338   $count = 1;
339  }
340
341  for (1 .. $count) {
342   ++$test;
343
344   my $skip_str = "ok $test # skip";
345   if (defined $reason) {
346    _sanitize_comment($reason);
347    $skip_str  .= " $reason" if length $reason;
348   }
349
350   local $\;
351   print $TAP_STREAM "$skip_str\n";
352  }
353
354  no warnings 'exiting';
355  last SKIP;
356 }
357
358 =head2 C<done_testing [ $count ]>
359
360 See L<Test::More/done_testing>.
361
362 =cut
363
364 sub done_testing {
365  my ($count) = @_;
366
367  lock $plan if THREADSAFE;
368
369  $count = $test unless defined $count;
370  croak("Number of tests must be a positive integer.  You gave it '$count'")
371                                                  unless $count =~ /^\+?[0-9]+$/;
372
373  if (not defined $plan or $plan == NO_PLAN) {
374   $plan         = $count; # $plan can't be NO_PLAN anymore
375   $done_testing = 1;
376   local $\;
377   print $TAP_STREAM "1..$plan\n";
378  } else {
379   if ($done_testing) {
380    @_ = ('done_testing() was already called');
381    goto &fail;
382   } elsif ($plan != $count) {
383    @_ = ("planned to run $plan tests but done_testing() expects $count");
384    goto &fail;
385   }
386  }
387
388  return 1;
389 }
390
391 =head2 C<ok $ok [, $desc ]>
392
393 See L<Test::More/ok>.
394
395 =cut
396
397 sub ok ($;$) {
398  my ($ok, $desc) = @_;
399
400  lock $plan if THREADSAFE;
401
402  ++$test;
403
404  my $test_str = "ok $test";
405  unless ($ok) {
406   $test_str   = "not $test_str";
407   ++$failed;
408  }
409  if (defined $desc) {
410   _sanitize_comment($desc);
411   $test_str .= " - $desc" if length $desc;
412  }
413
414  local $\;
415  print $TAP_STREAM "$test_str\n";
416
417  return $ok;
418 }
419
420 =head2 C<pass [ $desc ]>
421
422 See L<Test::More/pass>.
423
424 =cut
425
426 sub pass (;$) {
427  unshift @_, 1;
428  goto &ok;
429 }
430
431 =head2 C<fail [ $desc ]>
432
433 See L<Test::More/fail>.
434
435 =cut
436
437 sub fail (;$) {
438  unshift @_, 0;
439  goto &ok;
440 }
441
442 =head2 C<is $got, $expected [, $desc ]>
443
444 See L<Test::More/is>.
445
446 =cut
447
448 sub is ($$;$) {
449  my ($got, $expected, $desc) = @_;
450  no warnings 'uninitialized';
451  @_ = (
452   (not(defined $got xor defined $expected) and $got eq $expected),
453   $desc,
454  );
455  goto &ok;
456 }
457
458 =head2 C<isnt $got, $expected [, $desc ]>
459
460 See L<Test::More/isnt>.
461
462 =cut
463
464 sub isnt ($$;$) {
465  my ($got, $expected, $desc) = @_;
466  no warnings 'uninitialized';
467  @_ = (
468   ((defined $got xor defined $expected) or $got ne $expected),
469   $desc,
470  );
471  goto &ok;
472 }
473
474 my %binops = (
475  'or'  => 'or',
476  'xor' => 'xor',
477  'and' => 'and',
478
479  '||'  => 'hor',
480  ('//' => 'dor') x ($] >= 5.010),
481  '&&'  => 'hand',
482
483  '|'   => 'bor',
484  '^'   => 'bxor',
485  '&'   => 'band',
486
487  'lt'  => 'lt',
488  'le'  => 'le',
489  'gt'  => 'gt',
490  'ge'  => 'ge',
491  'eq'  => 'eq',
492  'ne'  => 'ne',
493  'cmp' => 'cmp',
494
495  '<'   => 'nlt',
496  '<='  => 'nle',
497  '>'   => 'ngt',
498  '>='  => 'nge',
499  '=='  => 'neq',
500  '!='  => 'nne',
501  '<=>' => 'ncmp',
502
503  '=~'  => 'like',
504  '!~'  => 'unlike',
505  ('~~' => 'smartmatch') x ($] >= 5.010),
506
507  '+'   => 'add',
508  '-'   => 'substract',
509  '*'   => 'multiply',
510  '/'   => 'divide',
511  '%'   => 'modulo',
512  '<<'  => 'lshift',
513  '>>'  => 'rshift',
514
515  '.'   => 'concat',
516  '..'  => 'flipflop',
517  '...' => 'altflipflop',
518  ','   => 'comma',
519  '=>'  => 'fatcomma',
520 );
521
522 my %binop_handlers;
523
524 sub _create_binop_handler {
525  my ($op) = @_;
526  my $name = $binops{$op};
527  croak("Operator $op not supported") unless defined $name;
528  {
529   local $@;
530   eval <<"IS_BINOP";
531 sub is_$name (\$\$;\$) {
532  my (\$got, \$expected, \$desc) = \@_;
533  \@_ = (scalar(\$got $op \$expected), \$desc);
534  goto &ok;
535 }
536 IS_BINOP
537   die $@ if $@;
538  }
539  $binop_handlers{$op} = do {
540   no strict 'refs';
541   \&{__PACKAGE__."::is_$name"};
542  }
543 }
544
545 =head2 C<like $got, $regexp_expected [, $desc ]>
546
547 See L<Test::More/like>.
548
549 =head2 C<unlike $got, $regexp_expected, [, $desc ]>
550
551 See L<Test::More/unlike>.
552
553 =cut
554
555 {
556  no warnings 'once';
557  *like   = _create_binop_handler('=~');
558  *unlike = _create_binop_handler('!~');
559 }
560
561 =head2 C<cmp_ok $got, $op, $expected [, $desc ]>
562
563 See L<Test::More/cmp_ok>.
564
565 =cut
566
567 sub cmp_ok ($$$;$) {
568  my ($got, $op, $expected, $desc) = @_;
569  my $handler = $binop_handlers{$op};
570  unless ($handler) {
571   local $Test::More::Level = ($Test::More::Level || 0) + 1;
572   $handler = _create_binop_handler($op);
573  }
574  @_ = ($got, $expected, $desc);
575  goto $handler;
576 }
577
578 =head2 C<is_deeply $got, $expected [, $desc ]>
579
580 See L<Test::More/is_deeply>.
581
582 =cut
583
584 BEGIN {
585  local $@;
586  if (eval { require Scalar::Util; 1 }) {
587   *_reftype = \&Scalar::Util::reftype;
588  } else {
589   # Stolen from Scalar::Util::PP
590   require B;
591   my %tmap = qw<
592    B::NULL   SCALAR
593
594    B::HV     HASH
595    B::AV     ARRAY
596    B::CV     CODE
597    B::IO     IO
598    B::GV     GLOB
599    B::REGEXP REGEXP
600   >;
601   *_reftype = sub ($) {
602    my $r = shift;
603
604    return undef unless length ref $r;
605
606    my $t = ref B::svref_2object($r);
607
608    return exists $tmap{$t} ? $tmap{$t}
609                            : length ref $$r ? 'REF'
610                                             : 'SCALAR'
611   }
612  }
613 }
614
615 sub _deep_ref_check {
616  my ($x, $y, $ry) = @_;
617
618  no warnings qw<numeric uninitialized>;
619
620  if ($ry eq 'ARRAY') {
621   return 0 unless $#$x == $#$y;
622
623   my ($ex, $ey);
624   for (0 .. $#$y) {
625    $ex = $x->[$_];
626    $ey = $y->[$_];
627
628    # Inline the beginning of _deep_check
629    return 0 if defined $ex xor defined $ey;
630
631    next if not(ref $ex xor ref $ey) and $ex eq $ey;
632
633    $ry = _reftype($ey);
634    return 0 if _reftype($ex) ne $ry;
635
636    return 0 unless $ry and _deep_ref_check($ex, $ey, $ry);
637   }
638
639   return 1;
640  } elsif ($ry eq 'HASH') {
641   return 0 unless keys(%$x) == keys(%$y);
642
643   my ($ex, $ey);
644   for (keys %$y) {
645    return 0 unless exists $x->{$_};
646    $ex = $x->{$_};
647    $ey = $y->{$_};
648
649    # Inline the beginning of _deep_check
650    return 0 if defined $ex xor defined $ey;
651
652    next if not(ref $ex xor ref $ey) and $ex eq $ey;
653
654    $ry = _reftype($ey);
655    return 0 if _reftype($ex) ne $ry;
656
657    return 0 unless $ry and _deep_ref_check($ex, $ey, $ry);
658   }
659
660   return 1;
661  } elsif ($ry eq 'SCALAR' or $ry eq 'REF') {
662   return _deep_check($$x, $$y);
663  }
664
665  return 0;
666 }
667
668 sub _deep_check {
669  my ($x, $y) = @_;
670
671  no warnings qw<numeric uninitialized>;
672
673  return 0 if defined $x xor defined $y;
674
675  # Try object identity/eq overloading first. It also covers the case where
676  # $x and $y are both undefined.
677  # If either $x or $y is overloaded but none has eq overloading, the test will
678  # break at that point.
679  return 1 if not(ref $x xor ref $y) and $x eq $y;
680
681  # Test::More::is_deeply happily breaks encapsulation if the objects aren't
682  # overloaded.
683  my $ry = _reftype($y);
684  return 0 if _reftype($x) ne $ry;
685
686  # Shortcut if $x and $y are both not references and failed the previous
687  # $x eq $y test.
688  return 0 unless $ry;
689
690  # We know that $x and $y are both references of type $ry, without overloading.
691  _deep_ref_check($x, $y, $ry);
692 }
693
694 sub is_deeply {
695  @_ = (
696   &_deep_check,
697   $_[2],
698  );
699  goto &ok;
700 }
701
702 sub _diag_fh {
703  my $fh = shift;
704
705  return unless @_;
706
707  lock $plan if THREADSAFE;
708  return if $no_diag;
709
710  my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
711  _sanitize_comment($msg);
712  return unless length $msg;
713
714  local $\;
715  print $fh "# $msg\n";
716
717  return 0;
718 };
719
720 =head2 C<diag @text>
721
722 See L<Test::More/diag>.
723
724 =cut
725
726 sub diag {
727  unshift @_, $DIAG_STREAM;
728  goto &_diag_fh;
729 }
730
731 =head2 C<note @text>
732
733 See L<Test::More/note>.
734
735 =cut
736
737 sub note {
738  unshift @_, $TAP_STREAM;
739  goto &_diag_fh;
740 }
741
742 =head2 C<BAIL_OUT [ $desc ]>
743
744 See L<Test::More/BAIL_OUT>.
745
746 =cut
747
748 sub BAIL_OUT {
749  my ($desc) = @_;
750
751  lock $plan if THREADSAFE;
752
753  my $bail_out_str = 'Bail out!';
754  if (defined $desc) {
755   _sanitize_comment($desc);
756   $bail_out_str  .= "  $desc" if length $desc; # Two spaces
757  }
758
759  local $\;
760  print $TAP_STREAM "$bail_out_str\n";
761
762  exit 255;
763 }
764
765 END {
766  if ($main_process == $$ and not $?) {
767   lock $plan if THREADSAFE;
768
769   if (defined $plan) {
770    if ($failed) {
771     $? = $failed <= 254 ? $failed : 254;
772    } elsif ($plan >= 0) {
773     $? = $test == $plan ? 0 : 255;
774    }
775    if ($plan == NO_PLAN) {
776     local $\;
777     print $TAP_STREAM "1..$test\n";
778    }
779   }
780  }
781 }
782
783 =pod
784
785 L<Test::Leaner> also provides some functions of its own, which are never exported.
786
787 =head2 C<tap_stream [ $fh ]>
788
789 Read/write accessor for the filehandle to which the tests are outputted.
790 On write, it also turns autoflush on onto C<$fh>.
791
792 Note that it can only be used as a write accessor before you start any thread, as L<threads::shared> cannot reliably share filehandles.
793
794 Defaults to C<STDOUT>.
795
796 =cut
797
798 sub tap_stream (;*) {
799  if (@_) {
800   $TAP_STREAM = $_[0];
801
802   my $fh = select $TAP_STREAM;
803   $|++;
804   select $fh;
805  }
806
807  return $TAP_STREAM;
808 }
809
810 tap_stream *STDOUT;
811
812 =head2 C<diag_stream [ $fh ]>
813
814 Read/write accessor for the filehandle to which the diagnostics are printed.
815 On write, it also turns autoflush on onto C<$fh>.
816
817 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.
818
819 Defaults to C<STDERR>.
820
821 =cut
822
823 sub diag_stream (;*) {
824  if (@_) {
825   $DIAG_STREAM = $_[0];
826
827   my $fh = select $DIAG_STREAM;
828   $|++;
829   select $fh;
830  }
831
832  return $DIAG_STREAM;
833 }
834
835 diag_stream *STDERR;
836
837 =head2 C<THREADSAFE>
838
839 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>.
840 In that case, it also needs a working L<threads::shared>.
841
842 =head1 DEPENDENCIES
843
844 L<perl> 5.6.
845
846 L<Exporter>, L<Test::More>.
847
848 =head1 AUTHOR
849
850 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
851
852 You can contact me by mail or on C<irc.perl.org> (vincent).
853
854 =head1 BUGS
855
856 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>.
857 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
858
859 =head1 SUPPORT
860
861 You can find documentation for this module with the perldoc command.
862
863     perldoc Test::Leaner
864
865 =head1 COPYRIGHT & LICENSE
866
867 Copyright 2010 Vincent Pit, all rights reserved.
868
869 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
870
871 =cut
872
873 1; # End of Test::Leaner