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 if (defined $replacement) {
174 $valid_imports{$_} = 1;
177 @_ = ("$_ is not implemented in this version of Test::More");
181 no warnings 'redefine';
182 $leaner_stash->{$_} = $replacement;
188 my @imports = &_handle_import_args;
189 @imports = @EXPORT unless @imports;
190 my @test_more_imports;
192 if ($valid_imports{$_}) {
193 push @test_more_imports, $_;
197 *{$pkg."::$_"} = $leaner_stash->{$_};
201 my $test_more_import = 'Test::More'->can('import');
202 return unless $test_more_import;
207 import => \@test_more_imports,
210 lock $plan if THREADSAFE;
211 push @_, 'no_diag' if $no_diag;
214 goto $test_more_import;
217 no warnings 'redefine';
223 sub NO_PLAN () { -1 }
224 sub SKIP_ALL () { -2 }
228 threads::shared::share($_) for $plan, $test, $failed, $no_diag, $done_testing;
231 lock $plan if THREADSAFE;
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 warn @_, " at $file line $line.\n";
249 my $level = 1 + ($Test::Builder::Level || 0);
252 @caller = caller $level--;
253 } while (!@caller and $level >= 0);
254 my ($file, $line) = @caller[1, 2];
255 die @_, " at $file line $line.\n";
258 sub _sanitize_comment {
261 $_[0] =~ s/\n/\n# /g;
266 The following functions from L<Test::More> are implemented and exported by default.
268 =head2 C<< plan [ tests => $count | 'no_plan' | skip_all => $reason ] >>
270 See L<Test::More/plan>.
275 my ($key, $value) = @_;
279 lock $plan if THREADSAFE;
281 croak("You tried to plan twice") if defined $plan;
285 if ($key eq 'no_plan') {
286 croak("no_plan takes no arguments") if $value;
288 } elsif ($key eq 'tests') {
289 croak("Got an undefined number of tests") unless defined $value;
290 croak("You said to run 0 tests") unless $value;
291 croak("Number of tests must be a positive integer. You gave it '$value'")
292 unless $value =~ /^\+?[0-9]+$/;
294 $plan_str = "1..$value";
295 } elsif ($key eq 'skip_all') {
297 $plan_str = '1..0 # SKIP';
298 if (defined $value) {
299 _sanitize_comment($value);
300 $plan_str .= " $value" if length $value;
303 my @args = grep defined, $key, $value;
304 croak("plan() doesn't understand @args");
307 if (defined $plan_str) {
309 print $TAP_STREAM "$plan_str\n";
312 exit 0 if $plan == SKIP_ALL;
320 my @imports = &_handle_import_args;
323 local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
327 @_ = ($class, @imports);
328 goto &Exporter::import;
331 =head2 C<< skip $reason => $count >>
333 See L<Test::More/skip>.
338 my ($reason, $count) = @_;
340 lock $plan if THREADSAFE;
342 if (not defined $count) {
343 carp("skip() needs to know \$how_many tests are in the block")
344 unless defined $plan and $plan == NO_PLAN;
346 } elsif ($count =~ /[^0-9]/) {
347 carp('skip() was passed a non-numeric number of tests. Did you get the arguments backwards?');
354 my $skip_str = "ok $test # skip";
355 if (defined $reason) {
356 _sanitize_comment($reason);
357 $skip_str .= " $reason" if length $reason;
361 print $TAP_STREAM "$skip_str\n";
364 no warnings 'exiting';
368 =head2 C<done_testing [ $count ]>
370 See L<Test::More/done_testing>.
377 lock $plan if THREADSAFE;
379 $count = $test unless defined $count;
380 croak("Number of tests must be a positive integer. You gave it '$count'")
381 unless $count =~ /^\+?[0-9]+$/;
383 if (not defined $plan or $plan == NO_PLAN) {
384 $plan = $count; # $plan can't be NO_PLAN anymore
387 print $TAP_STREAM "1..$plan\n";
390 @_ = ('done_testing() was already called');
392 } elsif ($plan != $count) {
393 @_ = ("planned to run $plan tests but done_testing() expects $count");
401 =head2 C<ok $ok [, $desc ]>
403 See L<Test::More/ok>.
408 my ($ok, $desc) = @_;
410 lock $plan if THREADSAFE;
414 my $test_str = "ok $test";
416 $test_str = "not $test_str";
420 _sanitize_comment($desc);
421 $test_str .= " - $desc" if length $desc;
425 print $TAP_STREAM "$test_str\n";
430 =head2 C<pass [ $desc ]>
432 See L<Test::More/pass>.
441 =head2 C<fail [ $desc ]>
443 See L<Test::More/fail>.
452 =head2 C<is $got, $expected [, $desc ]>
454 See L<Test::More/is>.
459 my ($got, $expected, $desc) = @_;
460 no warnings 'uninitialized';
462 (not(defined $got xor defined $expected) and $got eq $expected),
468 =head2 C<isnt $got, $expected [, $desc ]>
470 See L<Test::More/isnt>.
475 my ($got, $expected, $desc) = @_;
476 no warnings 'uninitialized';
478 ((defined $got xor defined $expected) or $got ne $expected),
490 ('//' => 'dor') x ($] >= 5.010),
515 ('~~' => 'smartmatch') x ($] >= 5.010),
527 '...' => 'altflipflop',
534 sub _create_binop_handler {
536 my $name = $binops{$op};
537 croak("Operator $op not supported") unless defined $name;
541 sub is_$name (\$\$;\$) {
542 my (\$got, \$expected, \$desc) = \@_;
543 \@_ = (scalar(\$got $op \$expected), \$desc);
549 $binop_handlers{$op} = do {
551 \&{__PACKAGE__."::is_$name"};
555 =head2 C<like $got, $regexp_expected [, $desc ]>
557 See L<Test::More/like>.
559 =head2 C<unlike $got, $regexp_expected, [, $desc ]>
561 See L<Test::More/unlike>.
567 *like = _create_binop_handler('=~');
568 *unlike = _create_binop_handler('!~');
571 =head2 C<cmp_ok $got, $op, $expected [, $desc ]>
573 See L<Test::More/cmp_ok>.
578 my ($got, $op, $expected, $desc) = @_;
579 my $handler = $binop_handlers{$op};
581 local $Test::More::Level = ($Test::More::Level || 0) + 1;
582 $handler = _create_binop_handler($op);
584 @_ = ($got, $expected, $desc);
588 =head2 C<is_deeply $got, $expected [, $desc ]>
590 See L<Test::More/is_deeply>.
596 if (eval { require Scalar::Util; 1 }) {
597 *_reftype = \&Scalar::Util::reftype;
599 # Stolen from Scalar::Util::PP
611 *_reftype = sub ($) {
614 return undef unless length ref $r;
616 my $t = ref B::svref_2object($r);
618 return exists $tmap{$t} ? $tmap{$t}
619 : length ref $$r ? 'REF'
625 sub _deep_ref_check {
626 my ($x, $y, $ry) = @_;
628 no warnings qw<numeric uninitialized>;
630 if ($ry eq 'ARRAY') {
631 return 0 unless $#$x == $#$y;
638 # Inline the beginning of _deep_check
639 return 0 if defined $ex xor defined $ey;
641 next if not(ref $ex xor ref $ey) and $ex eq $ey;
644 return 0 if _reftype($ex) ne $ry;
646 return 0 unless $ry and _deep_ref_check($ex, $ey, $ry);
650 } elsif ($ry eq 'HASH') {
651 return 0 unless keys(%$x) == keys(%$y);
655 return 0 unless exists $x->{$_};
659 # Inline the beginning of _deep_check
660 return 0 if defined $ex xor defined $ey;
662 next if not(ref $ex xor ref $ey) and $ex eq $ey;
665 return 0 if _reftype($ex) ne $ry;
667 return 0 unless $ry and _deep_ref_check($ex, $ey, $ry);
671 } elsif ($ry eq 'SCALAR' or $ry eq 'REF') {
672 return _deep_check($$x, $$y);
681 no warnings qw<numeric uninitialized>;
683 return 0 if defined $x xor defined $y;
685 # Try object identity/eq overloading first. It also covers the case where
686 # $x and $y are both undefined.
687 # If either $x or $y is overloaded but none has eq overloading, the test will
688 # break at that point.
689 return 1 if not(ref $x xor ref $y) and $x eq $y;
691 # Test::More::is_deeply happily breaks encapsulation if the objects aren't
693 my $ry = _reftype($y);
694 return 0 if _reftype($x) ne $ry;
696 # Shortcut if $x and $y are both not references and failed the previous
700 # We know that $x and $y are both references of type $ry, without overloading.
701 _deep_ref_check($x, $y, $ry);
717 lock $plan if THREADSAFE;
720 my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
721 _sanitize_comment($msg);
722 return unless length $msg;
725 print $fh "# $msg\n";
732 See L<Test::More/diag>.
737 unshift @_, $DIAG_STREAM;
743 See L<Test::More/note>.
748 unshift @_, $TAP_STREAM;
752 =head2 C<BAIL_OUT [ $desc ]>
754 See L<Test::More/BAIL_OUT>.
761 lock $plan if THREADSAFE;
763 my $bail_out_str = 'Bail out!';
765 _sanitize_comment($desc);
766 $bail_out_str .= " $desc" if length $desc; # Two spaces
770 print $TAP_STREAM "$bail_out_str\n";
776 if ($main_process == $$ and not $?) {
777 lock $plan if THREADSAFE;
781 $? = $failed <= 254 ? $failed : 254;
782 } elsif ($plan >= 0) {
783 $? = $test == $plan ? 0 : 255;
785 if ($plan == NO_PLAN) {
787 print $TAP_STREAM "1..$test\n";
795 L<Test::Leaner> also provides some functions of its own, which are never exported.
797 =head2 C<tap_stream [ $fh ]>
799 Read/write accessor for the filehandle to which the tests are outputted.
800 On write, it also turns autoflush on onto C<$fh>.
802 Note that it can only be used as a write accessor before you start any thread, as L<threads::shared> cannot reliably share filehandles.
804 Defaults to C<STDOUT>.
808 sub tap_stream (;*) {
812 my $fh = select $TAP_STREAM;
822 =head2 C<diag_stream [ $fh ]>
824 Read/write accessor for the filehandle to which the diagnostics are printed.
825 On write, it also turns autoflush on onto C<$fh>.
827 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.
829 Defaults to C<STDERR>.
833 sub diag_stream (;*) {
835 $DIAG_STREAM = $_[0];
837 my $fh = select $DIAG_STREAM;
849 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>.
850 In that case, it also needs a working L<threads::shared>.
856 L<Exporter>, L<Test::More>.
860 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
862 You can contact me by mail or on C<irc.perl.org> (vincent).
866 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>.
867 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
871 You can find documentation for this module with the perldoc command.
875 =head1 COPYRIGHT & LICENSE
877 Copyright 2010,2011 Vincent Pit, all rights reserved.
879 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
883 1; # End of Test::Leaner