9 Test::Leaner - A slimmer Test::More for when you favor performance over completeness.
17 our $VERSION = '0.02';
21 use Test::Leaner tests => 10_000;
24 is $one, 1, "checking situation $_";
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>.
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 :
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), L</isnt> honors C<'ne'> overloading, and L</cmp_ok> honors whichever overloading category corresponds to the specified operator.
44 L</pass>, L</fail>, L</ok>, L</is>, L</isnt>, L</like>, L</unlike>, L</cmp_ok> and L</is_deeply> are all guaranteed to return the truth value of the test.
48 C<isn't> (the sub C<t> in package C<isn>) is not aliased to L</isnt>.
52 L</like> and L</unlike> don't special case regular expressions that are passed as C<'/.../'> strings.
53 A string regexp argument is always treated as 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>).
57 L</cmp_ok> throws an exception if the given operator isn't a valid Perl binary operator (except C<'='> and variants).
58 It also tests in scalar context, so C<'..'> will be treated as the flip-flop operator and not the range operator.
62 L</is_deeply> doesn't guard for memory cycles.
63 If the two first arguments present parallel memory cycles, the test may result in an infinite loop.
67 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.
68 Moreover, this allows a much faster variant of L</is_deeply>.
72 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.
85 if ($] >= 5.008 and $INC{'threads.pm'}) {
86 my $use_ithreads = do {
89 $Config::Config{useithreads};
92 require threads::shared;
93 *THREADSAFE = sub () { 1 };
96 unless (defined &Test::Leaner::THREADSAFE) {
97 *THREADSAFE = sub () { 0 }
101 my ($TAP_STREAM, $DIAG_STREAM);
103 my ($plan, $test, $failed, $no_diag, $done_testing);
125 =head2 C<PERL_TEST_LEANER_USES_TEST_MORE>
127 If this environment variable is set, L<Test::Leaner> will replace its functions by those from L<Test::More>.
128 Moreover, the symbols that are imported when 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).
129 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.
131 This may be useful if your L<Test::Leaner>-based test script fails and you want extra diagnostics.
135 sub _handle_import_args {
143 if ($item eq 'import') {
144 push @imports, @{ $_[$i+1] };
146 } elsif ($item eq 'no_diag') {
147 lock $plan if THREADSAFE;
153 splice @_, $i, $splice;
162 if ($ENV{PERL_TEST_LEANER_USES_TEST_MORE}) {
165 my $leaner_stash = \%Test::Leaner::;
166 my $more_stash = \%Test::More::;
171 my $replacement = exists $more_stash->{$_} ? *{$more_stash->{$_}}{CODE}
173 unless (defined $replacement) {
176 @_ = ("$_ is not implemented in this version of Test::More");
180 no warnings 'redefine';
181 $leaner_stash->{$_} = $replacement;
187 my @imports = &_handle_import_args;
188 @imports = @EXPORT unless @imports;
189 my @test_more_imports;
194 *{$pkg."::$_"} = $leaner_stash->{$_};
195 } elsif (/^!/ or !exists $more_stash->{$_} or exists $leaner_stash->{$_}) {
196 push @test_more_imports, $_;
198 # Croak for symbols in Test::More but not in Test::Leaner
199 Exporter::import($class, $_);
203 my $test_more_import = 'Test::More'->can('import');
204 return unless $test_more_import;
209 import => \@test_more_imports,
212 lock $plan if THREADSAFE;
213 push @_, 'no_diag' if $no_diag;
216 goto $test_more_import;
219 no warnings 'redefine';
225 sub NO_PLAN () { -1 }
226 sub SKIP_ALL () { -2 }
230 threads::shared::share($_) for $plan, $test, $failed, $no_diag, $done_testing;
233 lock $plan if THREADSAFE;
241 my $level = 1 + ($Test::Builder::Level || 0);
244 @caller = caller $level--;
245 } while (!@caller and $level >= 0);
246 my ($file, $line) = @caller[1, 2];
247 warn @_, " at $file line $line.\n";
251 my $level = 1 + ($Test::Builder::Level || 0);
254 @caller = caller $level--;
255 } while (!@caller and $level >= 0);
256 my ($file, $line) = @caller[1, 2];
257 die @_, " at $file line $line.\n";
260 sub _sanitize_comment {
263 $_[0] =~ s/\n/\n# /g;
268 The following functions from L<Test::More> are implemented and exported by default.
270 =head2 C<< plan [ tests => $count | 'no_plan' | skip_all => $reason ] >>
272 See L<Test::More/plan>.
277 my ($key, $value) = @_;
281 lock $plan if THREADSAFE;
283 croak("You tried to plan twice") if defined $plan;
287 if ($key eq 'no_plan') {
288 croak("no_plan takes no arguments") if $value;
290 } elsif ($key eq 'tests') {
291 croak("Got an undefined number of tests") unless defined $value;
292 croak("You said to run 0 tests") unless $value;
293 croak("Number of tests must be a positive integer. You gave it '$value'")
294 unless $value =~ /^\+?[0-9]+$/;
296 $plan_str = "1..$value";
297 } elsif ($key eq 'skip_all') {
299 $plan_str = '1..0 # SKIP';
300 if (defined $value) {
301 _sanitize_comment($value);
302 $plan_str .= " $value" if length $value;
305 my @args = grep defined, $key, $value;
306 croak("plan() doesn't understand @args");
309 if (defined $plan_str) {
311 print $TAP_STREAM "$plan_str\n";
314 exit 0 if $plan == SKIP_ALL;
322 my @imports = &_handle_import_args;
325 local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
329 @_ = ($class, @imports);
330 goto &Exporter::import;
333 =head2 C<< skip $reason => $count >>
335 See L<Test::More/skip>.
340 my ($reason, $count) = @_;
342 lock $plan if THREADSAFE;
344 if (not defined $count) {
345 carp("skip() needs to know \$how_many tests are in the block")
346 unless defined $plan and $plan == NO_PLAN;
348 } elsif ($count =~ /[^0-9]/) {
349 carp('skip() was passed a non-numeric number of tests. Did you get the arguments backwards?');
356 my $skip_str = "ok $test # skip";
357 if (defined $reason) {
358 _sanitize_comment($reason);
359 $skip_str .= " $reason" if length $reason;
363 print $TAP_STREAM "$skip_str\n";
366 no warnings 'exiting';
370 =head2 C<done_testing [ $count ]>
372 See L<Test::More/done_testing>.
379 lock $plan if THREADSAFE;
381 $count = $test unless defined $count;
382 croak("Number of tests must be a positive integer. You gave it '$count'")
383 unless $count =~ /^\+?[0-9]+$/;
385 if (not defined $plan or $plan == NO_PLAN) {
386 $plan = $count; # $plan can't be NO_PLAN anymore
389 print $TAP_STREAM "1..$plan\n";
392 @_ = ('done_testing() was already called');
394 } elsif ($plan != $count) {
395 @_ = ("planned to run $plan tests but done_testing() expects $count");
403 =head2 C<ok $ok [, $desc ]>
405 See L<Test::More/ok>.
410 my ($ok, $desc) = @_;
412 lock $plan if THREADSAFE;
416 my $test_str = "ok $test";
418 $test_str = "not $test_str";
422 _sanitize_comment($desc);
423 $test_str .= " - $desc" if length $desc;
427 print $TAP_STREAM "$test_str\n";
432 =head2 C<pass [ $desc ]>
434 See L<Test::More/pass>.
443 =head2 C<fail [ $desc ]>
445 See L<Test::More/fail>.
454 =head2 C<is $got, $expected [, $desc ]>
456 See L<Test::More/is>.
461 my ($got, $expected, $desc) = @_;
462 no warnings 'uninitialized';
464 (not(defined $got xor defined $expected) and $got eq $expected),
470 =head2 C<isnt $got, $expected [, $desc ]>
472 See L<Test::More/isnt>.
477 my ($got, $expected, $desc) = @_;
478 no warnings 'uninitialized';
480 ((defined $got xor defined $expected) or $got ne $expected),
492 ('//' => 'dor') x ($] >= 5.010),
517 ('~~' => 'smartmatch') x ($] >= 5.010),
529 '...' => 'altflipflop',
536 sub _create_binop_handler {
538 my $name = $binops{$op};
539 croak("Operator $op not supported") unless defined $name;
543 sub is_$name (\$\$;\$) {
544 my (\$got, \$expected, \$desc) = \@_;
545 \@_ = (scalar(\$got $op \$expected), \$desc);
551 $binop_handlers{$op} = do {
553 \&{__PACKAGE__."::is_$name"};
557 =head2 C<like $got, $regexp_expected [, $desc ]>
559 See L<Test::More/like>.
561 =head2 C<unlike $got, $regexp_expected, [, $desc ]>
563 See L<Test::More/unlike>.
569 *like = _create_binop_handler('=~');
570 *unlike = _create_binop_handler('!~');
573 =head2 C<cmp_ok $got, $op, $expected [, $desc ]>
575 See L<Test::More/cmp_ok>.
580 my ($got, $op, $expected, $desc) = @_;
581 my $handler = $binop_handlers{$op};
583 local $Test::More::Level = ($Test::More::Level || 0) + 1;
584 $handler = _create_binop_handler($op);
586 @_ = ($got, $expected, $desc);
590 =head2 C<is_deeply $got, $expected [, $desc ]>
592 See L<Test::More/is_deeply>.
598 if (eval { require Scalar::Util; 1 }) {
599 *_reftype = \&Scalar::Util::reftype;
601 # Stolen from Scalar::Util::PP
613 *_reftype = sub ($) {
616 return undef unless length ref $r;
618 my $t = ref B::svref_2object($r);
620 return exists $tmap{$t} ? $tmap{$t}
621 : length ref $$r ? 'REF'
627 sub _deep_ref_check {
628 my ($x, $y, $ry) = @_;
630 no warnings qw<numeric uninitialized>;
632 if ($ry eq 'ARRAY') {
633 return 0 unless $#$x == $#$y;
640 # Inline the beginning of _deep_check
641 return 0 if defined $ex xor defined $ey;
643 next if not(ref $ex xor ref $ey) and $ex eq $ey;
646 return 0 if _reftype($ex) ne $ry;
648 return 0 unless $ry and _deep_ref_check($ex, $ey, $ry);
652 } elsif ($ry eq 'HASH') {
653 return 0 unless keys(%$x) == keys(%$y);
657 return 0 unless exists $x->{$_};
661 # Inline the beginning of _deep_check
662 return 0 if defined $ex xor defined $ey;
664 next if not(ref $ex xor ref $ey) and $ex eq $ey;
667 return 0 if _reftype($ex) ne $ry;
669 return 0 unless $ry and _deep_ref_check($ex, $ey, $ry);
673 } elsif ($ry eq 'SCALAR' or $ry eq 'REF') {
674 return _deep_check($$x, $$y);
683 no warnings qw<numeric uninitialized>;
685 return 0 if defined $x xor defined $y;
687 # Try object identity/eq overloading first. It also covers the case where
688 # $x and $y are both undefined.
689 # If either $x or $y is overloaded but none has eq overloading, the test will
690 # break at that point.
691 return 1 if not(ref $x xor ref $y) and $x eq $y;
693 # Test::More::is_deeply happily breaks encapsulation if the objects aren't
695 my $ry = _reftype($y);
696 return 0 if _reftype($x) ne $ry;
698 # Shortcut if $x and $y are both not references and failed the previous
702 # We know that $x and $y are both references of type $ry, without overloading.
703 _deep_ref_check($x, $y, $ry);
719 lock $plan if THREADSAFE;
722 my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
723 _sanitize_comment($msg);
724 return unless length $msg;
727 print $fh "# $msg\n";
734 See L<Test::More/diag>.
739 unshift @_, $DIAG_STREAM;
745 See L<Test::More/note>.
750 unshift @_, $TAP_STREAM;
754 =head2 C<BAIL_OUT [ $desc ]>
756 See L<Test::More/BAIL_OUT>.
763 lock $plan if THREADSAFE;
765 my $bail_out_str = 'Bail out!';
767 _sanitize_comment($desc);
768 $bail_out_str .= " $desc" if length $desc; # Two spaces
772 print $TAP_STREAM "$bail_out_str\n";
778 if ($main_process == $$ and not $?) {
779 lock $plan if THREADSAFE;
783 $? = $failed <= 254 ? $failed : 254;
784 } elsif ($plan >= 0) {
785 $? = $test == $plan ? 0 : 255;
787 if ($plan == NO_PLAN) {
789 print $TAP_STREAM "1..$test\n";
797 L<Test::Leaner> also provides some functions of its own, which are never exported.
799 =head2 C<tap_stream [ $fh ]>
801 Read/write accessor for the filehandle to which the tests are outputted.
802 On write, it also turns autoflush on onto C<$fh>.
804 Note that it can only be used as a write accessor before you start any thread, as L<threads::shared> cannot reliably share filehandles.
806 Defaults to C<STDOUT>.
810 sub tap_stream (;*) {
814 my $fh = select $TAP_STREAM;
824 =head2 C<diag_stream [ $fh ]>
826 Read/write accessor for the filehandle to which the diagnostics are printed.
827 On write, it also turns autoflush on onto C<$fh>.
829 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.
831 Defaults to C<STDERR>.
835 sub diag_stream (;*) {
837 $DIAG_STREAM = $_[0];
839 my $fh = select $DIAG_STREAM;
851 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>.
852 In that case, it also needs a working L<threads::shared>.
858 L<Exporter>, L<Test::More>.
862 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
864 You can contact me by mail or on C<irc.perl.org> (vincent).
868 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>.
869 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
873 You can find documentation for this module with the perldoc command.
877 =head1 COPYRIGHT & LICENSE
879 Copyright 2010,2011 Vincent Pit, all rights reserved.
881 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
885 1; # End of Test::Leaner