9 Test::Leaner - A slimmer Test::More for when you favor performance over completeness.
17 our $VERSION = '0.04';
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 if (@imports == grep /^!/, @imports) {
189 # All imports are negated, or @imports is empty
191 /^!(.*)/ and ++$negated{$1} for @imports;
192 push @imports, grep !$negated{$_}, @EXPORT;
195 my @test_more_imports;
200 *{$pkg."::$_"} = $leaner_stash->{$_};
201 } elsif (/^!/ or !exists $more_stash->{$_} or exists $leaner_stash->{$_}) {
202 push @test_more_imports, $_;
204 # Croak for symbols in Test::More but not in Test::Leaner
205 Exporter::import($class, $_);
209 my $test_more_import = 'Test::More'->can('import');
210 return unless $test_more_import;
215 import => \@test_more_imports,
218 lock $plan if THREADSAFE;
219 push @_, 'no_diag' if $no_diag;
222 goto $test_more_import;
225 no warnings 'redefine';
231 sub NO_PLAN () { -1 }
232 sub SKIP_ALL () { -2 }
236 threads::shared::share($_) for $plan, $test, $failed, $no_diag, $done_testing;
239 lock $plan if THREADSAFE;
247 my $level = 1 + ($Test::Builder::Level || 0);
250 @caller = caller $level--;
251 } while (!@caller and $level >= 0);
252 my ($file, $line) = @caller[1, 2];
253 warn @_, " at $file line $line.\n";
257 my $level = 1 + ($Test::Builder::Level || 0);
260 @caller = caller $level--;
261 } while (!@caller and $level >= 0);
262 my ($file, $line) = @caller[1, 2];
263 die @_, " at $file line $line.\n";
266 sub _sanitize_comment {
269 $_[0] =~ s/\n/\n# /g;
274 The following functions from L<Test::More> are implemented and exported by default.
276 =head2 C<< plan [ tests => $count | 'no_plan' | skip_all => $reason ] >>
278 See L<Test::More/plan>.
283 my ($key, $value) = @_;
287 lock $plan if THREADSAFE;
289 croak("You tried to plan twice") if defined $plan;
293 if ($key eq 'no_plan') {
294 croak("no_plan takes no arguments") if $value;
296 } elsif ($key eq 'tests') {
297 croak("Got an undefined number of tests") unless defined $value;
298 croak("You said to run 0 tests") unless $value;
299 croak("Number of tests must be a positive integer. You gave it '$value'")
300 unless $value =~ /^\+?[0-9]+$/;
302 $plan_str = "1..$value";
303 } elsif ($key eq 'skip_all') {
305 $plan_str = '1..0 # SKIP';
306 if (defined $value) {
307 _sanitize_comment($value);
308 $plan_str .= " $value" if length $value;
311 my @args = grep defined, $key, $value;
312 croak("plan() doesn't understand @args");
315 if (defined $plan_str) {
317 print $TAP_STREAM "$plan_str\n";
320 exit 0 if $plan == SKIP_ALL;
328 my @imports = &_handle_import_args;
331 local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
335 @_ = ($class, @imports);
336 goto &Exporter::import;
339 =head2 C<< skip $reason => $count >>
341 See L<Test::More/skip>.
346 my ($reason, $count) = @_;
348 lock $plan if THREADSAFE;
350 if (not defined $count) {
351 carp("skip() needs to know \$how_many tests are in the block")
352 unless defined $plan and $plan == NO_PLAN;
354 } elsif ($count =~ /[^0-9]/) {
355 carp('skip() was passed a non-numeric number of tests. Did you get the arguments backwards?');
362 my $skip_str = "ok $test # skip";
363 if (defined $reason) {
364 _sanitize_comment($reason);
365 $skip_str .= " $reason" if length $reason;
369 print $TAP_STREAM "$skip_str\n";
372 no warnings 'exiting';
376 =head2 C<done_testing [ $count ]>
378 See L<Test::More/done_testing>.
385 lock $plan if THREADSAFE;
387 $count = $test unless defined $count;
388 croak("Number of tests must be a positive integer. You gave it '$count'")
389 unless $count =~ /^\+?[0-9]+$/;
391 if (not defined $plan or $plan == NO_PLAN) {
392 $plan = $count; # $plan can't be NO_PLAN anymore
395 print $TAP_STREAM "1..$plan\n";
398 @_ = ('done_testing() was already called');
400 } elsif ($plan != $count) {
401 @_ = ("planned to run $plan tests but done_testing() expects $count");
409 =head2 C<ok $ok [, $desc ]>
411 See L<Test::More/ok>.
416 my ($ok, $desc) = @_;
418 lock $plan if THREADSAFE;
422 my $test_str = "ok $test";
424 $test_str = "not $test_str";
428 _sanitize_comment($desc);
429 $test_str .= " - $desc" if length $desc;
433 print $TAP_STREAM "$test_str\n";
438 =head2 C<pass [ $desc ]>
440 See L<Test::More/pass>.
449 =head2 C<fail [ $desc ]>
451 See L<Test::More/fail>.
460 =head2 C<is $got, $expected [, $desc ]>
462 See L<Test::More/is>.
467 my ($got, $expected, $desc) = @_;
468 no warnings 'uninitialized';
470 (not(defined $got xor defined $expected) and $got eq $expected),
476 =head2 C<isnt $got, $expected [, $desc ]>
478 See L<Test::More/isnt>.
483 my ($got, $expected, $desc) = @_;
484 no warnings 'uninitialized';
486 ((defined $got xor defined $expected) or $got ne $expected),
498 ('//' => 'dor') x ("$]" >= 5.010),
523 ('~~' => 'smartmatch') x ("$]" >= 5.010),
535 '...' => 'altflipflop',
542 sub _create_binop_handler {
544 my $name = $binops{$op};
545 croak("Operator $op not supported") unless defined $name;
549 sub is_$name (\$\$;\$) {
550 my (\$got, \$expected, \$desc) = \@_;
551 \@_ = (scalar(\$got $op \$expected), \$desc);
557 $binop_handlers{$op} = do {
559 \&{__PACKAGE__."::is_$name"};
563 =head2 C<like $got, $regexp_expected [, $desc ]>
565 See L<Test::More/like>.
567 =head2 C<unlike $got, $regexp_expected, [, $desc ]>
569 See L<Test::More/unlike>.
575 *like = _create_binop_handler('=~');
576 *unlike = _create_binop_handler('!~');
579 =head2 C<cmp_ok $got, $op, $expected [, $desc ]>
581 See L<Test::More/cmp_ok>.
586 my ($got, $op, $expected, $desc) = @_;
587 my $handler = $binop_handlers{$op};
589 local $Test::More::Level = ($Test::More::Level || 0) + 1;
590 $handler = _create_binop_handler($op);
592 @_ = ($got, $expected, $desc);
596 =head2 C<is_deeply $got, $expected [, $desc ]>
598 See L<Test::More/is_deeply>.
604 if (eval { require Scalar::Util; 1 }) {
605 *_reftype = \&Scalar::Util::reftype;
607 # Stolen from Scalar::Util::PP
619 *_reftype = sub ($) {
622 return undef unless length ref $r;
624 my $t = ref B::svref_2object($r);
626 return exists $tmap{$t} ? $tmap{$t}
627 : length ref $$r ? 'REF'
633 sub _deep_ref_check {
634 my ($x, $y, $ry) = @_;
636 no warnings qw<numeric uninitialized>;
638 if ($ry eq 'ARRAY') {
639 return 0 unless $#$x == $#$y;
646 # Inline the beginning of _deep_check
647 return 0 if defined $ex xor defined $ey;
649 next if not(ref $ex xor ref $ey) and $ex eq $ey;
652 return 0 if _reftype($ex) ne $ry;
654 return 0 unless $ry and _deep_ref_check($ex, $ey, $ry);
658 } elsif ($ry eq 'HASH') {
659 return 0 unless keys(%$x) == keys(%$y);
663 return 0 unless exists $x->{$_};
667 # Inline the beginning of _deep_check
668 return 0 if defined $ex xor defined $ey;
670 next if not(ref $ex xor ref $ey) and $ex eq $ey;
673 return 0 if _reftype($ex) ne $ry;
675 return 0 unless $ry and _deep_ref_check($ex, $ey, $ry);
679 } elsif ($ry eq 'SCALAR' or $ry eq 'REF') {
680 return _deep_check($$x, $$y);
689 no warnings qw<numeric uninitialized>;
691 return 0 if defined $x xor defined $y;
693 # Try object identity/eq overloading first. It also covers the case where
694 # $x and $y are both undefined.
695 # If either $x or $y is overloaded but none has eq overloading, the test will
696 # break at that point.
697 return 1 if not(ref $x xor ref $y) and $x eq $y;
699 # Test::More::is_deeply happily breaks encapsulation if the objects aren't
701 my $ry = _reftype($y);
702 return 0 if _reftype($x) ne $ry;
704 # Shortcut if $x and $y are both not references and failed the previous
708 # We know that $x and $y are both references of type $ry, without overloading.
709 _deep_ref_check($x, $y, $ry);
725 lock $plan if THREADSAFE;
728 my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
729 _sanitize_comment($msg);
730 return unless length $msg;
733 print $fh "# $msg\n";
740 See L<Test::More/diag>.
745 unshift @_, $DIAG_STREAM;
751 See L<Test::More/note>.
756 unshift @_, $TAP_STREAM;
760 =head2 C<BAIL_OUT [ $desc ]>
762 See L<Test::More/BAIL_OUT>.
769 lock $plan if THREADSAFE;
771 my $bail_out_str = 'Bail out!';
773 _sanitize_comment($desc);
774 $bail_out_str .= " $desc" if length $desc; # Two spaces
778 print $TAP_STREAM "$bail_out_str\n";
784 if ($main_process == $$ and not $?) {
785 lock $plan if THREADSAFE;
789 $? = $failed <= 254 ? $failed : 254;
790 } elsif ($plan >= 0) {
791 $? = $test == $plan ? 0 : 255;
793 if ($plan == NO_PLAN) {
795 print $TAP_STREAM "1..$test\n";
803 L<Test::Leaner> also provides some functions of its own, which are never exported.
805 =head2 C<tap_stream [ $fh ]>
807 Read/write accessor for the filehandle to which the tests are outputted.
808 On write, it also turns autoflush on onto C<$fh>.
810 Note that it can only be used as a write accessor before you start any thread, as L<threads::shared> cannot reliably share filehandles.
812 Defaults to C<STDOUT>.
816 sub tap_stream (;*) {
820 my $fh = select $TAP_STREAM;
830 =head2 C<diag_stream [ $fh ]>
832 Read/write accessor for the filehandle to which the diagnostics are printed.
833 On write, it also turns autoflush on onto C<$fh>.
835 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.
837 Defaults to C<STDERR>.
841 sub diag_stream (;*) {
843 $DIAG_STREAM = $_[0];
845 my $fh = select $DIAG_STREAM;
857 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>.
858 In that case, it also needs a working L<threads::shared>.
864 L<Exporter>, L<Test::More>.
868 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
870 You can contact me by mail or on C<irc.perl.org> (vincent).
874 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>.
875 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
879 You can find documentation for this module with the perldoc command.
883 =head1 COPYRIGHT & LICENSE
885 Copyright 2010,2011 Vincent Pit, all rights reserved.
887 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
889 Except for the fallback implementation of the internal C<_reftype> function, which has been taken from L<Scalar::Util> and is
891 Copyright 1997-2007 Graham Barr, all rights reserved.
893 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
897 1; # End of Test::Leaner