9 Test::Leaner - A slimmer Test::More for when you favor performance over completeness.
17 our $VERSION = '0.01';
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) 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> and L</cmp_ok> are all guaranteed to return the truth value of the test.
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>).
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.
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.
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.
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.
76 if ($] >= 5.008 and $INC{'threads.pm'}) {
77 my $use_ithreads = do {
80 $Config::Config{useithreads};
83 require threads::shared;
84 *THREADSAFE = sub () { 1 };
87 unless (defined &Test::Leaner::THREADSAFE) {
88 *THREADSAFE = sub () { 0 }
92 my ($TAP_STREAM, $DIAG_STREAM);
94 my ($plan, $test, $failed, $no_diag, $done_testing);
116 =head2 C<PERL_TEST_LEANER_USES_TEST_MORE>
118 If this environment variable is set, L<Test::Leaner> will replace its functions by those from L<Test::More>.
119 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).
120 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.
122 This may be useful if your L<Test::Leaner>-based test script fails and you want extra diagnostics.
126 sub _handle_import_args {
134 if ($item eq 'import') {
135 push @imports, @{ $_[$i+1] };
137 } elsif ($item eq 'no_diag') {
138 lock $plan if THREADSAFE;
144 splice @_, $i, $splice;
153 if ($ENV{PERL_TEST_LEANER_USES_TEST_MORE}) {
156 my $leaner_stash = \%Test::Leaner::;
157 my $more_stash = \%Test::More::;
162 my $replacement = exists $more_stash->{$_} ? *{$more_stash->{$_}}{CODE}
164 if (defined $replacement) {
165 $valid_imports{$_} = 1;
168 @_ = ("$_ is not implemented in this version of Test::More");
172 no warnings 'redefine';
173 $leaner_stash->{$_} = $replacement;
178 my @imports = &_handle_import_args;
179 @imports = @EXPORT unless @imports;
180 my @test_more_imports;
182 if ($valid_imports{$_}) {
183 push @test_more_imports, $_;
187 *{$pkg."::$_"} = $leaner_stash->{$_};
190 my $test_more_import = 'Test::More'->can('import');
194 import => \@test_more_imports,
197 lock $plan if THREADSAFE;
198 push @_, 'no_diag' if $no_diag;
200 goto $test_more_import;
203 no warnings 'redefine';
209 sub NO_PLAN () { -1 }
210 sub SKIP_ALL () { -2 }
214 threads::shared::share($_) for $plan, $test, $failed, $no_diag, $done_testing;
217 lock $plan if THREADSAFE;
225 my $level = 1 + ($Test::Builder::Level || 0);
228 @caller = caller $level--;
229 } while (!@caller and $level >= 0);
230 my ($file, $line) = @caller[1, 2];
231 warn @_, " at $file line $line.\n";
235 my $level = 1 + ($Test::Builder::Level || 0);
238 @caller = caller $level--;
239 } while (!@caller and $level >= 0);
240 my ($file, $line) = @caller[1, 2];
241 die @_, " at $file line $line.\n";
244 sub _sanitize_comment {
247 $_[0] =~ s/\n/\n# /g;
252 The following functions from L<Test::More> are implemented and exported by default.
254 =head2 C<< plan [ tests => $count | 'no_plan' | skip_all => $reason ] >>
256 See L<Test::More/plan>.
261 my ($key, $value) = @_;
265 lock $plan if THREADSAFE;
267 croak("You tried to plan twice") if defined $plan;
271 if ($key eq 'no_plan') {
272 croak("no_plan takes no arguments") if $value;
274 } elsif ($key eq 'tests') {
275 croak("Got an undefined number of tests") unless defined $value;
276 croak("You said to run 0 tests") unless $value;
277 croak("Number of tests must be a positive integer. You gave it '$value'")
278 unless $value =~ /^\+?[0-9]+$/;
280 $plan_str = "1..$value";
281 } elsif ($key eq 'skip_all') {
283 $plan_str = '1..0 # SKIP';
284 if (defined $value) {
285 _sanitize_comment($value);
286 $plan_str .= " $value" if length $value;
289 my @args = grep defined, $key, $value;
290 croak("plan() doesn't understand @args");
293 if (defined $plan_str) {
295 print $TAP_STREAM "$plan_str\n";
298 exit 0 if $plan == SKIP_ALL;
306 my @imports = &_handle_import_args;
309 local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
313 @_ = ($class, @imports);
314 goto &Exporter::import;
317 =head2 C<< skip $reason => $count >>
319 See L<Test::More/skip>.
324 my ($reason, $count) = @_;
326 lock $plan if THREADSAFE;
328 if (not defined $count) {
329 carp("skip() needs to know \$how_many tests are in the block")
330 unless defined $plan and $plan == NO_PLAN;
332 } elsif ($count =~ /[^0-9]/) {
333 carp('skip() was passed a non-numeric number of tests. Did you get the arguments backwards?');
340 my $skip_str = "ok $test # skip";
341 if (defined $reason) {
342 _sanitize_comment($reason);
343 $skip_str .= " $reason" if length $reason;
347 print $TAP_STREAM "$skip_str\n";
350 no warnings 'exiting';
354 =head2 C<done_testing [ $count ]>
356 See L<Test::More/done_testing>.
363 lock $plan if THREADSAFE;
365 $count = $test unless defined $count;
366 croak("Number of tests must be a positive integer. You gave it '$count'")
367 unless $count =~ /^\+?[0-9]+$/;
369 if (not defined $plan or $plan == NO_PLAN) {
370 $plan = $count; # $plan can't be NO_PLAN anymore
373 print $TAP_STREAM "1..$plan\n";
376 @_ = ('done_testing() was already called');
378 } elsif ($plan != $count) {
379 @_ = ("planned to run $plan tests but done_testing() expects $count");
387 =head2 C<ok $ok [, $desc ]>
389 See L<Test::More/ok>.
394 my ($ok, $desc) = @_;
396 lock $plan if THREADSAFE;
400 my $test_str = "ok $test";
402 $test_str = "not $test_str";
406 _sanitize_comment($desc);
407 $test_str .= " - $desc" if length $desc;
411 print $TAP_STREAM "$test_str\n";
416 =head2 C<pass [ $desc ]>
418 See L<Test::More/pass>.
427 =head2 C<fail [ $desc ]>
429 See L<Test::More/fail>.
438 =head2 C<is $got, $expected [, $desc ]>
440 See L<Test::More/is>.
445 my ($got, $expected, $desc) = @_;
446 no warnings 'uninitialized';
448 (not(defined $got xor defined $expected) and $got eq $expected),
454 =head2 C<isnt $got, $expected [, $desc ]>
456 See L<Test::More/isnt>.
461 my ($got, $expected, $desc) = @_;
462 no warnings 'uninitialized';
464 ((defined $got xor defined $expected) or $got ne $expected),
476 ('//' => 'dor') x ($] >= 5.010),
501 ('~~' => 'smartmatch') x ($] >= 5.010),
513 '...' => 'altflipflop',
520 sub _create_binop_handler {
522 my $name = $binops{$op};
523 croak("Operator $op not supported") unless defined $name;
527 sub is_$name (\$\$;\$) {
528 my (\$got, \$expected, \$desc) = \@_;
529 \@_ = (scalar(\$got $op \$expected), \$desc);
535 $binop_handlers{$op} = do {
537 \&{__PACKAGE__."::is_$name"};
541 =head2 C<like $got, $regexp_expected [, $desc ]>
543 See L<Test::More/like>.
545 =head2 C<unlike $got, $regexp_expected, [, $desc ]>
547 See L<Test::More/unlike>.
553 *like = _create_binop_handler('=~');
554 *unlike = _create_binop_handler('!~');
557 =head2 C<cmp_ok $got, $op, $expected [, $desc ]>
559 See L<Test::More/cmp_ok>.
564 my ($got, $op, $expected, $desc) = @_;
565 my $handler = $binop_handlers{$op};
567 local $Test::More::Level = ($Test::More::Level || 0) + 1;
568 $handler = _create_binop_handler($op);
570 @_ = ($got, $expected, $desc);
574 =head2 C<is_deeply $got, $expected [, $desc ]>
576 See L<Test::More/is_deeply>.
582 if (eval { require Scalar::Util; 1 }) {
583 *_reftype = \&Scalar::Util::reftype;
585 # Stolen from Scalar::Util::PP
597 *_reftype = sub ($) {
600 return undef unless length ref $r;
602 my $t = ref B::svref_2object($r);
604 return exists $tmap{$t} ? $tmap{$t}
605 : length ref $$r ? 'REF'
611 sub _deep_ref_check {
612 my ($x, $y, $ry) = @_;
614 no warnings qw<numeric uninitialized>;
616 if ($ry eq 'ARRAY') {
617 return 0 unless $#$x == $#$y;
624 # Inline the beginning of _deep_check
625 return 0 if defined $ex xor defined $ey;
627 next if not(ref $ex xor ref $ey) and $ex eq $ey;
630 return 0 if _reftype($ex) ne $ry;
632 return 0 unless $ry and _deep_ref_check($ex, $ey, $ry);
636 } elsif ($ry eq 'HASH') {
637 return 0 unless keys(%$x) == keys(%$y);
641 return 0 unless exists $x->{$_};
645 # Inline the beginning of _deep_check
646 return 0 if defined $ex xor defined $ey;
648 next if not(ref $ex xor ref $ey) and $ex eq $ey;
651 return 0 if _reftype($ex) ne $ry;
653 return 0 unless $ry and _deep_ref_check($ex, $ey, $ry);
657 } elsif ($ry eq 'SCALAR' or $ry eq 'REF') {
658 return _deep_check($$x, $$y);
667 no warnings qw<numeric uninitialized>;
669 return 0 if defined $x xor defined $y;
671 # Try object identity/eq overloading first. It also covers the case where
672 # $x and $y are both undefined.
673 # If either $x or $y is overloaded but none has eq overloading, the test will
674 # break at that point.
675 return 1 if not(ref $x xor ref $y) and $x eq $y;
677 # Test::More::is_deeply happily breaks encapsulation if the objects aren't
679 my $ry = _reftype($y);
680 return 0 if _reftype($x) ne $ry;
682 # Shortcut if $x and $y are both not references and failed the previous
686 # We know that $x and $y are both references of type $ry, without overloading.
687 _deep_ref_check($x, $y, $ry);
703 lock $plan if THREADSAFE;
706 my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
707 _sanitize_comment($msg);
708 return unless length $msg;
711 print $fh "# $msg\n";
718 See L<Test::More/diag>.
723 unshift @_, $DIAG_STREAM;
729 See L<Test::More/note>.
734 unshift @_, $TAP_STREAM;
738 =head2 C<BAIL_OUT [ $desc ]>
740 See L<Test::More/BAIL_OUT>.
747 lock $plan if THREADSAFE;
749 my $bail_out_str = 'Bail out!';
751 _sanitize_comment($desc);
752 $bail_out_str .= " $desc" if length $desc; # Two spaces
756 print $TAP_STREAM "$bail_out_str\n";
763 lock $plan if THREADSAFE;
767 $? = $failed <= 254 ? $failed : 254;
768 } elsif ($plan >= 0) {
769 $? = $test == $plan ? 0 : 255;
771 if ($plan == NO_PLAN) {
773 print $TAP_STREAM "1..$test\n";
781 L<Test::Leaner> also provides some functions of its own, which are never exported.
783 =head2 C<tap_stream [ $fh ]>
785 Read/write accessor for the filehandle to which the tests are outputted.
786 On write, it also turns autoflush on onto C<$fh>.
788 Note that it can only be used as a write accessor before you start any thread, as L<threads::shared> cannot reliably share filehandles.
790 Defaults to C<STDOUT>.
794 sub tap_stream (;*) {
798 my $fh = select $TAP_STREAM;
808 =head2 C<diag_stream [ $fh ]>
810 Read/write accessor for the filehandle to which the diagnostics are printed.
811 On write, it also turns autoflush on onto C<$fh>.
813 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.
815 Defaults to C<STDERR>.
819 sub diag_stream (;*) {
821 $DIAG_STREAM = $_[0];
823 my $fh = select $DIAG_STREAM;
835 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>.
836 In that case, it also needs a working L<threads::shared>.
842 L<Exporter>, L<Test::More>.
846 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
848 You can contact me by mail or on C<irc.perl.org> (vincent).
852 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>.
853 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
857 You can find documentation for this module with the perldoc command.
861 =head1 COPYRIGHT & LICENSE
863 Copyright 2010 Vincent Pit, all rights reserved.
865 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
869 1; # End of Test::Leaner