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) 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.
80 if ($] >= 5.008 and $INC{'threads.pm'}) {
81 my $use_ithreads = do {
84 $Config::Config{useithreads};
87 require threads::shared;
88 *THREADSAFE = sub () { 1 };
91 unless (defined &Test::Leaner::THREADSAFE) {
92 *THREADSAFE = sub () { 0 }
96 my ($TAP_STREAM, $DIAG_STREAM);
98 my ($plan, $test, $failed, $no_diag, $done_testing);
120 =head2 C<PERL_TEST_LEANER_USES_TEST_MORE>
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.
126 This may be useful if your L<Test::Leaner>-based test script fails and you want extra diagnostics.
130 sub _handle_import_args {
138 if ($item eq 'import') {
139 push @imports, @{ $_[$i+1] };
141 } elsif ($item eq 'no_diag') {
142 lock $plan if THREADSAFE;
148 splice @_, $i, $splice;
157 if ($ENV{PERL_TEST_LEANER_USES_TEST_MORE}) {
160 my $leaner_stash = \%Test::Leaner::;
161 my $more_stash = \%Test::More::;
166 my $replacement = exists $more_stash->{$_} ? *{$more_stash->{$_}}{CODE}
168 if (defined $replacement) {
169 $valid_imports{$_} = 1;
172 @_ = ("$_ is not implemented in this version of Test::More");
176 no warnings 'redefine';
177 $leaner_stash->{$_} = $replacement;
182 my @imports = &_handle_import_args;
183 @imports = @EXPORT unless @imports;
184 my @test_more_imports;
186 if ($valid_imports{$_}) {
187 push @test_more_imports, $_;
191 *{$pkg."::$_"} = $leaner_stash->{$_};
194 my $test_more_import = 'Test::More'->can('import');
198 import => \@test_more_imports,
201 lock $plan if THREADSAFE;
202 push @_, 'no_diag' if $no_diag;
204 goto $test_more_import;
207 no warnings 'redefine';
213 sub NO_PLAN () { -1 }
214 sub SKIP_ALL () { -2 }
218 threads::shared::share($_) for $plan, $test, $failed, $no_diag, $done_testing;
221 lock $plan if THREADSAFE;
229 my $level = 1 + ($Test::Builder::Level || 0);
232 @caller = caller $level--;
233 } while (!@caller and $level >= 0);
234 my ($file, $line) = @caller[1, 2];
235 warn @_, " at $file line $line.\n";
239 my $level = 1 + ($Test::Builder::Level || 0);
242 @caller = caller $level--;
243 } while (!@caller and $level >= 0);
244 my ($file, $line) = @caller[1, 2];
245 die @_, " at $file line $line.\n";
248 sub _sanitize_comment {
251 $_[0] =~ s/\n/\n# /g;
256 The following functions from L<Test::More> are implemented and exported by default.
258 =head2 C<< plan [ tests => $count | 'no_plan' | skip_all => $reason ] >>
260 See L<Test::More/plan>.
265 my ($key, $value) = @_;
269 lock $plan if THREADSAFE;
271 croak("You tried to plan twice") if defined $plan;
275 if ($key eq 'no_plan') {
276 croak("no_plan takes no arguments") if $value;
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]+$/;
284 $plan_str = "1..$value";
285 } elsif ($key eq 'skip_all') {
287 $plan_str = '1..0 # SKIP';
288 if (defined $value) {
289 _sanitize_comment($value);
290 $plan_str .= " $value" if length $value;
293 my @args = grep defined, $key, $value;
294 croak("plan() doesn't understand @args");
297 if (defined $plan_str) {
299 print $TAP_STREAM "$plan_str\n";
302 exit 0 if $plan == SKIP_ALL;
310 my @imports = &_handle_import_args;
313 local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
317 @_ = ($class, @imports);
318 goto &Exporter::import;
321 =head2 C<< skip $reason => $count >>
323 See L<Test::More/skip>.
328 my ($reason, $count) = @_;
330 lock $plan if THREADSAFE;
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;
336 } elsif ($count =~ /[^0-9]/) {
337 carp('skip() was passed a non-numeric number of tests. Did you get the arguments backwards?');
344 my $skip_str = "ok $test # skip";
345 if (defined $reason) {
346 _sanitize_comment($reason);
347 $skip_str .= " $reason" if length $reason;
351 print $TAP_STREAM "$skip_str\n";
354 no warnings 'exiting';
358 =head2 C<done_testing [ $count ]>
360 See L<Test::More/done_testing>.
367 lock $plan if THREADSAFE;
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]+$/;
373 if (not defined $plan or $plan == NO_PLAN) {
374 $plan = $count; # $plan can't be NO_PLAN anymore
377 print $TAP_STREAM "1..$plan\n";
380 @_ = ('done_testing() was already called');
382 } elsif ($plan != $count) {
383 @_ = ("planned to run $plan tests but done_testing() expects $count");
391 =head2 C<ok $ok [, $desc ]>
393 See L<Test::More/ok>.
398 my ($ok, $desc) = @_;
400 lock $plan if THREADSAFE;
404 my $test_str = "ok $test";
406 $test_str = "not $test_str";
410 _sanitize_comment($desc);
411 $test_str .= " - $desc" if length $desc;
415 print $TAP_STREAM "$test_str\n";
420 =head2 C<pass [ $desc ]>
422 See L<Test::More/pass>.
431 =head2 C<fail [ $desc ]>
433 See L<Test::More/fail>.
442 =head2 C<is $got, $expected [, $desc ]>
444 See L<Test::More/is>.
449 my ($got, $expected, $desc) = @_;
450 no warnings 'uninitialized';
452 (not(defined $got xor defined $expected) and $got eq $expected),
458 =head2 C<isnt $got, $expected [, $desc ]>
460 See L<Test::More/isnt>.
465 my ($got, $expected, $desc) = @_;
466 no warnings 'uninitialized';
468 ((defined $got xor defined $expected) or $got ne $expected),
480 ('//' => 'dor') x ($] >= 5.010),
505 ('~~' => 'smartmatch') x ($] >= 5.010),
517 '...' => 'altflipflop',
524 sub _create_binop_handler {
526 my $name = $binops{$op};
527 croak("Operator $op not supported") unless defined $name;
531 sub is_$name (\$\$;\$) {
532 my (\$got, \$expected, \$desc) = \@_;
533 \@_ = (scalar(\$got $op \$expected), \$desc);
539 $binop_handlers{$op} = do {
541 \&{__PACKAGE__."::is_$name"};
545 =head2 C<like $got, $regexp_expected [, $desc ]>
547 See L<Test::More/like>.
549 =head2 C<unlike $got, $regexp_expected, [, $desc ]>
551 See L<Test::More/unlike>.
557 *like = _create_binop_handler('=~');
558 *unlike = _create_binop_handler('!~');
561 =head2 C<cmp_ok $got, $op, $expected [, $desc ]>
563 See L<Test::More/cmp_ok>.
568 my ($got, $op, $expected, $desc) = @_;
569 my $handler = $binop_handlers{$op};
571 local $Test::More::Level = ($Test::More::Level || 0) + 1;
572 $handler = _create_binop_handler($op);
574 @_ = ($got, $expected, $desc);
578 =head2 C<is_deeply $got, $expected [, $desc ]>
580 See L<Test::More/is_deeply>.
586 if (eval { require Scalar::Util; 1 }) {
587 *_reftype = \&Scalar::Util::reftype;
589 # Stolen from Scalar::Util::PP
601 *_reftype = sub ($) {
604 return undef unless length ref $r;
606 my $t = ref B::svref_2object($r);
608 return exists $tmap{$t} ? $tmap{$t}
609 : length ref $$r ? 'REF'
615 sub _deep_ref_check {
616 my ($x, $y, $ry) = @_;
618 no warnings qw<numeric uninitialized>;
620 if ($ry eq 'ARRAY') {
621 return 0 unless $#$x == $#$y;
628 # Inline the beginning of _deep_check
629 return 0 if defined $ex xor defined $ey;
631 next if not(ref $ex xor ref $ey) and $ex eq $ey;
634 return 0 if _reftype($ex) ne $ry;
636 return 0 unless $ry and _deep_ref_check($ex, $ey, $ry);
640 } elsif ($ry eq 'HASH') {
641 return 0 unless keys(%$x) == keys(%$y);
645 return 0 unless exists $x->{$_};
649 # Inline the beginning of _deep_check
650 return 0 if defined $ex xor defined $ey;
652 next if not(ref $ex xor ref $ey) and $ex eq $ey;
655 return 0 if _reftype($ex) ne $ry;
657 return 0 unless $ry and _deep_ref_check($ex, $ey, $ry);
661 } elsif ($ry eq 'SCALAR' or $ry eq 'REF') {
662 return _deep_check($$x, $$y);
671 no warnings qw<numeric uninitialized>;
673 return 0 if defined $x xor defined $y;
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;
681 # Test::More::is_deeply happily breaks encapsulation if the objects aren't
683 my $ry = _reftype($y);
684 return 0 if _reftype($x) ne $ry;
686 # Shortcut if $x and $y are both not references and failed the previous
690 # We know that $x and $y are both references of type $ry, without overloading.
691 _deep_ref_check($x, $y, $ry);
707 lock $plan if THREADSAFE;
710 my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
711 _sanitize_comment($msg);
712 return unless length $msg;
715 print $fh "# $msg\n";
722 See L<Test::More/diag>.
727 unshift @_, $DIAG_STREAM;
733 See L<Test::More/note>.
738 unshift @_, $TAP_STREAM;
742 =head2 C<BAIL_OUT [ $desc ]>
744 See L<Test::More/BAIL_OUT>.
751 lock $plan if THREADSAFE;
753 my $bail_out_str = 'Bail out!';
755 _sanitize_comment($desc);
756 $bail_out_str .= " $desc" if length $desc; # Two spaces
760 print $TAP_STREAM "$bail_out_str\n";
766 if ($main_process == $$ and not $?) {
767 lock $plan if THREADSAFE;
771 $? = $failed <= 254 ? $failed : 254;
772 } elsif ($plan >= 0) {
773 $? = $test == $plan ? 0 : 255;
775 if ($plan == NO_PLAN) {
777 print $TAP_STREAM "1..$test\n";
785 L<Test::Leaner> also provides some functions of its own, which are never exported.
787 =head2 C<tap_stream [ $fh ]>
789 Read/write accessor for the filehandle to which the tests are outputted.
790 On write, it also turns autoflush on onto C<$fh>.
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.
794 Defaults to C<STDOUT>.
798 sub tap_stream (;*) {
802 my $fh = select $TAP_STREAM;
812 =head2 C<diag_stream [ $fh ]>
814 Read/write accessor for the filehandle to which the diagnostics are printed.
815 On write, it also turns autoflush on onto C<$fh>.
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.
819 Defaults to C<STDERR>.
823 sub diag_stream (;*) {
825 $DIAG_STREAM = $_[0];
827 my $fh = select $DIAG_STREAM;
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>.
846 L<Exporter>, L<Test::More>.
850 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
852 You can contact me by mail or on C<irc.perl.org> (vincent).
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.
861 You can find documentation for this module with the perldoc command.
865 =head1 COPYRIGHT & LICENSE
867 Copyright 2010 Vincent Pit, all rights reserved.
869 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
873 1; # End of Test::Leaner