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.
71 L<Test::Leaner> depends on L<Scalar::Util>, while L<Test::More> does not.
81 if ($] >= 5.008 and $INC{'threads.pm'}) {
82 my $use_ithreads = do {
85 $Config::Config{useithreads};
88 require threads::shared;
89 *THREADSAFE = sub () { 1 };
92 unless (defined &Test::Leaner::THREADSAFE) {
93 *THREADSAFE = sub () { 0 }
97 my ($TAP_STREAM, $DIAG_STREAM);
99 my ($plan, $test, $failed, $no_diag, $done_testing);
101 sub NO_PLAN () { -1 }
102 sub SKIP_ALL () { -2 }
106 threads::shared::share($_) for $plan, $test, $failed, $no_diag, $done_testing;
109 lock $plan if THREADSAFE;
117 my $level = 1 + ($Test::Builder::Level || 0);
118 my ($file, $line) = (caller $level)[1, 2];
119 warn @_, " at $file line $line.\n";
123 my $level = 1 + ($Test::Builder::Level || 0);
124 my ($file, $line) = (caller $level)[1, 2];
125 die @_, " at $file line $line.\n";
128 sub _sanitize_comment {
131 $_[0] =~ s/\n/\n# /g;
136 The following functions from L<Test::More> are implemented and exported by default.
138 =head2 C<< plan [ tests => $count | 'no_plan' | skip_all => $reason ] >>
143 my ($key, $value) = @_;
147 lock $plan if THREADSAFE;
149 croak("You tried to plan twice") if defined $plan;
153 if ($key eq 'no_plan') {
154 croak("no_plan takes no arguments") if $value;
156 } elsif ($key eq 'tests') {
157 croak("Got an undefined number of tests") unless defined $value;
158 croak("You said to run 0 tests") unless $value;
159 croak("Number of tests must be a positive integer. You gave it '$value'")
160 unless $value =~ /^\+?[0-9]+$/;
162 $plan_str = "1..$value";
163 } elsif ($key eq 'skip_all') {
165 $plan_str = '1..0 # SKIP';
166 if (defined $value) {
167 _sanitize_comment($value);
168 $plan_str .= " $value" if length $value;
171 my @args = grep defined, $key, $value;
172 croak("plan() doesn't understand @args");
175 if (defined $plan_str) {
177 print $TAP_STREAM "$plan_str\n";
180 exit 0 if $plan == SKIP_ALL;
212 if ($item eq 'import') {
213 push @imports, @{ $_[$i+1] };
215 } elsif ($item eq 'no_diag') {
216 lock $plan if THREADSAFE;
222 splice @_, $i, $splice;
229 local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
233 @_ = ($class, @imports);
234 goto &Exporter::import;
237 =head2 C<< skip $reason => $count >>
242 my ($reason, $count) = @_;
244 lock $plan if THREADSAFE;
246 if (not defined $count) {
247 carp("skip() needs to know \$how_many tests are in the block")
248 unless defined $plan and $plan == NO_PLAN;
250 } elsif ($count =~ /[^0-9]/) {
251 carp('skip() was passed a non-numeric number of tests. Did you get the arguments backwards?');
258 my $skip_str = "ok $test # skip";
259 if (defined $reason) {
260 _sanitize_comment($reason);
261 $skip_str .= " $reason" if length $reason;
265 print $TAP_STREAM "$skip_str\n";
268 no warnings 'exiting';
272 =head2 C<done_testing [ $count ]>
279 lock $plan if THREADSAFE;
281 $count = $test unless defined $count;
282 croak("Number of tests must be a positive integer. You gave it '$count'")
283 unless $count =~ /^\+?[0-9]+$/;
285 if (not defined $plan or $plan == NO_PLAN) {
286 $plan = $count; # $plan can't be NO_PLAN anymore
289 print $TAP_STREAM "1..$plan\n";
292 @_ = ('done_testing() was already called');
294 } elsif ($plan != $count) {
295 @_ = ("planned to run $plan tests but done_testing() expects $count");
303 =head2 C<ok $ok [, $desc ]>
308 my ($ok, $desc) = @_;
310 lock $plan if THREADSAFE;
314 my $test_str = "ok $test";
316 $test_str = "not $test_str";
320 _sanitize_comment($desc);
321 $test_str .= " - $desc" if length $desc;
325 print $TAP_STREAM "$test_str\n";
330 =head2 C<pass [ $desc ]>
339 =head2 C<fail [ $desc ]>
348 =head2 C<is $got, $expected [, $desc ]>
353 my ($got, $expected, $desc) = @_;
354 no warnings 'uninitialized';
356 (not(defined $got xor defined $expected) and $got eq $expected),
362 =head2 C<isnt $got, $expected [, $desc ]>
367 my ($got, $expected, $desc) = @_;
368 no warnings 'uninitialized';
370 ((defined $got xor defined $expected) or $got ne $expected),
382 ('//' => 'dor') x ($] >= 5.010),
407 ('~~' => 'smartmatch') x ($] >= 5.010),
419 '...' => 'altflipflop',
426 sub _create_binop_handler {
428 my $name = $binops{$op};
429 croak("Operator $op not supported") unless defined $name;
433 sub is_$name (\$\$;\$) {
434 my (\$got, \$expected, \$desc) = \@_;
435 \@_ = (scalar(\$got $op \$expected), \$desc);
441 $binop_handlers{$op} = do {
443 \&{__PACKAGE__."::is_$name"};
447 =head2 C<like $got, $regexp_expected [, $desc ]>
451 =head2 C<unlike $got, $regexp_expected, [, $desc ]>
457 *like = _create_binop_handler('=~');
458 *unlike = _create_binop_handler('!~');
461 =head2 C<cmp_ok $got, $op, $expected [, $desc ]>
466 my ($got, $op, $expected, $desc) = @_;
467 my $handler = $binop_handlers{$op};
469 local $Test::More::Level = ($Test::More::Level || 0) + 1;
470 $handler = _create_binop_handler($op);
472 @_ = ($got, $expected, $desc);
476 =head2 C<is_deeply $got, $expected [, $desc ]>
483 no warnings qw<numeric uninitialized>;
485 return 0 if defined($x) xor defined($y);
487 # Try object identity/eq overloading first. It also covers the case where
488 # $x and $y are both undefined.
489 # If either $x or $y is overloaded but none has eq overloading, the test will
490 # break at that point.
491 return 1 if not(ref($x) xor ref($y)) and $x eq $y;
493 # Test::More::is_deeply happily breaks encapsulation if the objects aren't
495 my $ry = Scalar::Util::reftype($y);
496 return 0 if Scalar::Util::reftype($x) ne $ry;
498 # Shortcut if $x and $y are both not references and failed the previous
502 if ($ry eq 'ARRAY') {
504 # Prevent vivification of deleted elements by fetching the array values.
506 _deep_check($ex = $x->[$_], $ey = $y->[$_]) or return 0 for 0 .. $#$x;
509 } elsif ($ry eq 'HASH') {
510 if (keys(%$x) == keys(%$y)) {
511 (exists $x->{$_} and _deep_check($x->{$_}, $y->{$_}))
512 or return 0 for keys %$y;
515 } elsif ($ry eq 'SCALAR' or $ry eq 'REF') {
516 return _deep_check($$x, $$y);
535 lock $plan if THREADSAFE;
538 my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
539 _sanitize_comment($msg);
540 return unless length $msg;
543 print $fh "# $msg\n";
553 unshift @_, $DIAG_STREAM;
562 unshift @_, $TAP_STREAM;
566 =head2 C<BAIL_OUT [ $desc ]>
573 lock $plan if THREADSAFE;
575 my $bail_out_str = 'Bail out!';
577 _sanitize_comment($desc);
578 $bail_out_str .= " $desc" if length $desc; # Two spaces
582 print $TAP_STREAM "$bail_out_str\n";
589 lock $plan if THREADSAFE;
593 $? = $failed <= 254 ? $failed : 254;
594 } elsif ($plan >= 0) {
595 $? = $test == $plan ? 0 : 255;
596 } elsif ($plan == NO_PLAN) {
598 print $TAP_STREAM "1..$test\n";
606 L<Test::Leaner> also provides some functions of its own, which are never exported.
608 =head2 C<tap_stream [ $fh ]>
610 Read/write accessor for the filehandle to which the tests are outputted.
611 On write, it also turns autoflush on onto C<$fh>.
613 Note that it can only be used as a write accessor before you start any thread, as L<threads::shared> cannot reliably share filehandles.
615 Defaults to C<STDOUT>.
619 sub tap_stream (;*) {
623 my $fh = select $TAP_STREAM;
633 =head2 C<diag_stream [ $fh ]>
635 Read/write accessor for the filehandle to which the diagnostics are printed.
636 On write, it also turns autoflush on onto C<$fh>.
638 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.
640 Defaults to C<STDERR>.
644 sub diag_stream (;*) {
646 $DIAG_STREAM = $_[0];
648 my $fh = select $DIAG_STREAM;
660 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>.
661 In that case, it also needs a working L<threads::shared>.
667 L<Exporter>, L<Scalar::Util>, L<Test::More>.
671 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
673 You can contact me by mail or on C<irc.perl.org> (vincent).
677 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>.
678 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
682 You can find documentation for this module with the perldoc command.
686 =head1 COPYRIGHT & LICENSE
688 Copyright 2010 Vincent Pit, all rights reserved.
690 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
694 1; # End of Test::Leaner