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->{$_};
196 push @test_more_imports, $_;
200 my $test_more_import = 'Test::More'->can('import');
201 return unless $test_more_import;
206 import => \@test_more_imports,
209 lock $plan if THREADSAFE;
210 push @_, 'no_diag' if $no_diag;
213 goto $test_more_import;
216 no warnings 'redefine';
222 sub NO_PLAN () { -1 }
223 sub SKIP_ALL () { -2 }
227 threads::shared::share($_) for $plan, $test, $failed, $no_diag, $done_testing;
230 lock $plan if THREADSAFE;
238 my $level = 1 + ($Test::Builder::Level || 0);
241 @caller = caller $level--;
242 } while (!@caller and $level >= 0);
243 my ($file, $line) = @caller[1, 2];
244 warn @_, " at $file line $line.\n";
248 my $level = 1 + ($Test::Builder::Level || 0);
251 @caller = caller $level--;
252 } while (!@caller and $level >= 0);
253 my ($file, $line) = @caller[1, 2];
254 die @_, " at $file line $line.\n";
257 sub _sanitize_comment {
260 $_[0] =~ s/\n/\n# /g;
265 The following functions from L<Test::More> are implemented and exported by default.
267 =head2 C<< plan [ tests => $count | 'no_plan' | skip_all => $reason ] >>
269 See L<Test::More/plan>.
274 my ($key, $value) = @_;
278 lock $plan if THREADSAFE;
280 croak("You tried to plan twice") if defined $plan;
284 if ($key eq 'no_plan') {
285 croak("no_plan takes no arguments") if $value;
287 } elsif ($key eq 'tests') {
288 croak("Got an undefined number of tests") unless defined $value;
289 croak("You said to run 0 tests") unless $value;
290 croak("Number of tests must be a positive integer. You gave it '$value'")
291 unless $value =~ /^\+?[0-9]+$/;
293 $plan_str = "1..$value";
294 } elsif ($key eq 'skip_all') {
296 $plan_str = '1..0 # SKIP';
297 if (defined $value) {
298 _sanitize_comment($value);
299 $plan_str .= " $value" if length $value;
302 my @args = grep defined, $key, $value;
303 croak("plan() doesn't understand @args");
306 if (defined $plan_str) {
308 print $TAP_STREAM "$plan_str\n";
311 exit 0 if $plan == SKIP_ALL;
319 my @imports = &_handle_import_args;
322 local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
326 @_ = ($class, @imports);
327 goto &Exporter::import;
330 =head2 C<< skip $reason => $count >>
332 See L<Test::More/skip>.
337 my ($reason, $count) = @_;
339 lock $plan if THREADSAFE;
341 if (not defined $count) {
342 carp("skip() needs to know \$how_many tests are in the block")
343 unless defined $plan and $plan == NO_PLAN;
345 } elsif ($count =~ /[^0-9]/) {
346 carp('skip() was passed a non-numeric number of tests. Did you get the arguments backwards?');
353 my $skip_str = "ok $test # skip";
354 if (defined $reason) {
355 _sanitize_comment($reason);
356 $skip_str .= " $reason" if length $reason;
360 print $TAP_STREAM "$skip_str\n";
363 no warnings 'exiting';
367 =head2 C<done_testing [ $count ]>
369 See L<Test::More/done_testing>.
376 lock $plan if THREADSAFE;
378 $count = $test unless defined $count;
379 croak("Number of tests must be a positive integer. You gave it '$count'")
380 unless $count =~ /^\+?[0-9]+$/;
382 if (not defined $plan or $plan == NO_PLAN) {
383 $plan = $count; # $plan can't be NO_PLAN anymore
386 print $TAP_STREAM "1..$plan\n";
389 @_ = ('done_testing() was already called');
391 } elsif ($plan != $count) {
392 @_ = ("planned to run $plan tests but done_testing() expects $count");
400 =head2 C<ok $ok [, $desc ]>
402 See L<Test::More/ok>.
407 my ($ok, $desc) = @_;
409 lock $plan if THREADSAFE;
413 my $test_str = "ok $test";
415 $test_str = "not $test_str";
419 _sanitize_comment($desc);
420 $test_str .= " - $desc" if length $desc;
424 print $TAP_STREAM "$test_str\n";
429 =head2 C<pass [ $desc ]>
431 See L<Test::More/pass>.
440 =head2 C<fail [ $desc ]>
442 See L<Test::More/fail>.
451 =head2 C<is $got, $expected [, $desc ]>
453 See L<Test::More/is>.
458 my ($got, $expected, $desc) = @_;
459 no warnings 'uninitialized';
461 (not(defined $got xor defined $expected) and $got eq $expected),
467 =head2 C<isnt $got, $expected [, $desc ]>
469 See L<Test::More/isnt>.
474 my ($got, $expected, $desc) = @_;
475 no warnings 'uninitialized';
477 ((defined $got xor defined $expected) or $got ne $expected),
489 ('//' => 'dor') x ($] >= 5.010),
514 ('~~' => 'smartmatch') x ($] >= 5.010),
526 '...' => 'altflipflop',
533 sub _create_binop_handler {
535 my $name = $binops{$op};
536 croak("Operator $op not supported") unless defined $name;
540 sub is_$name (\$\$;\$) {
541 my (\$got, \$expected, \$desc) = \@_;
542 \@_ = (scalar(\$got $op \$expected), \$desc);
548 $binop_handlers{$op} = do {
550 \&{__PACKAGE__."::is_$name"};
554 =head2 C<like $got, $regexp_expected [, $desc ]>
556 See L<Test::More/like>.
558 =head2 C<unlike $got, $regexp_expected, [, $desc ]>
560 See L<Test::More/unlike>.
566 *like = _create_binop_handler('=~');
567 *unlike = _create_binop_handler('!~');
570 =head2 C<cmp_ok $got, $op, $expected [, $desc ]>
572 See L<Test::More/cmp_ok>.
577 my ($got, $op, $expected, $desc) = @_;
578 my $handler = $binop_handlers{$op};
580 local $Test::More::Level = ($Test::More::Level || 0) + 1;
581 $handler = _create_binop_handler($op);
583 @_ = ($got, $expected, $desc);
587 =head2 C<is_deeply $got, $expected [, $desc ]>
589 See L<Test::More/is_deeply>.
595 if (eval { require Scalar::Util; 1 }) {
596 *_reftype = \&Scalar::Util::reftype;
598 # Stolen from Scalar::Util::PP
610 *_reftype = sub ($) {
613 return undef unless length ref $r;
615 my $t = ref B::svref_2object($r);
617 return exists $tmap{$t} ? $tmap{$t}
618 : length ref $$r ? 'REF'
624 sub _deep_ref_check {
625 my ($x, $y, $ry) = @_;
627 no warnings qw<numeric uninitialized>;
629 if ($ry eq 'ARRAY') {
630 return 0 unless $#$x == $#$y;
637 # Inline the beginning of _deep_check
638 return 0 if defined $ex xor defined $ey;
640 next if not(ref $ex xor ref $ey) and $ex eq $ey;
643 return 0 if _reftype($ex) ne $ry;
645 return 0 unless $ry and _deep_ref_check($ex, $ey, $ry);
649 } elsif ($ry eq 'HASH') {
650 return 0 unless keys(%$x) == keys(%$y);
654 return 0 unless exists $x->{$_};
658 # Inline the beginning of _deep_check
659 return 0 if defined $ex xor defined $ey;
661 next if not(ref $ex xor ref $ey) and $ex eq $ey;
664 return 0 if _reftype($ex) ne $ry;
666 return 0 unless $ry and _deep_ref_check($ex, $ey, $ry);
670 } elsif ($ry eq 'SCALAR' or $ry eq 'REF') {
671 return _deep_check($$x, $$y);
680 no warnings qw<numeric uninitialized>;
682 return 0 if defined $x xor defined $y;
684 # Try object identity/eq overloading first. It also covers the case where
685 # $x and $y are both undefined.
686 # If either $x or $y is overloaded but none has eq overloading, the test will
687 # break at that point.
688 return 1 if not(ref $x xor ref $y) and $x eq $y;
690 # Test::More::is_deeply happily breaks encapsulation if the objects aren't
692 my $ry = _reftype($y);
693 return 0 if _reftype($x) ne $ry;
695 # Shortcut if $x and $y are both not references and failed the previous
699 # We know that $x and $y are both references of type $ry, without overloading.
700 _deep_ref_check($x, $y, $ry);
716 lock $plan if THREADSAFE;
719 my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
720 _sanitize_comment($msg);
721 return unless length $msg;
724 print $fh "# $msg\n";
731 See L<Test::More/diag>.
736 unshift @_, $DIAG_STREAM;
742 See L<Test::More/note>.
747 unshift @_, $TAP_STREAM;
751 =head2 C<BAIL_OUT [ $desc ]>
753 See L<Test::More/BAIL_OUT>.
760 lock $plan if THREADSAFE;
762 my $bail_out_str = 'Bail out!';
764 _sanitize_comment($desc);
765 $bail_out_str .= " $desc" if length $desc; # Two spaces
769 print $TAP_STREAM "$bail_out_str\n";
775 if ($main_process == $$ and not $?) {
776 lock $plan if THREADSAFE;
780 $? = $failed <= 254 ? $failed : 254;
781 } elsif ($plan >= 0) {
782 $? = $test == $plan ? 0 : 255;
784 if ($plan == NO_PLAN) {
786 print $TAP_STREAM "1..$test\n";
794 L<Test::Leaner> also provides some functions of its own, which are never exported.
796 =head2 C<tap_stream [ $fh ]>
798 Read/write accessor for the filehandle to which the tests are outputted.
799 On write, it also turns autoflush on onto C<$fh>.
801 Note that it can only be used as a write accessor before you start any thread, as L<threads::shared> cannot reliably share filehandles.
803 Defaults to C<STDOUT>.
807 sub tap_stream (;*) {
811 my $fh = select $TAP_STREAM;
821 =head2 C<diag_stream [ $fh ]>
823 Read/write accessor for the filehandle to which the diagnostics are printed.
824 On write, it also turns autoflush on onto C<$fh>.
826 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.
828 Defaults to C<STDERR>.
832 sub diag_stream (;*) {
834 $DIAG_STREAM = $_[0];
836 my $fh = select $DIAG_STREAM;
848 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>.
849 In that case, it also needs a working L<threads::shared>.
855 L<Exporter>, L<Test::More>.
859 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
861 You can contact me by mail or on C<irc.perl.org> (vincent).
865 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>.
866 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
870 You can find documentation for this module with the perldoc command.
874 =head1 COPYRIGHT & LICENSE
876 Copyright 2010,2011 Vincent Pit, all rights reserved.
878 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
882 1; # End of Test::Leaner