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</cmp_ok> throws an exception if the given operator isn't a valid Perl binary operator (except C<'='> and variants).
49 It also tests in scalar context, so C<'..'> will be treated as the flip-flop operator and not the range operator.
53 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.
57 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.
61 L<Test::Leaner> depends on L<Scalar::Util>, while L<Test::More> does not.
71 if ($] >= 5.008 and $INC{'threads.pm'}) {
72 my $use_ithreads = do {
75 $Config::Config{useithreads};
78 require threads::shared;
79 *THREADSAFE = sub () { 1 };
82 unless (defined &Test::Leaner::THREADSAFE) {
83 *THREADSAFE = sub () { 0 }
87 my ($TAP_STREAM, $DIAG_STREAM);
89 my ($plan, $test, $failed, $no_diag, $done_testing);
92 sub SKIP_ALL () { -2 }
96 threads::shared::share($_) for $plan, $test, $failed, $no_diag, $done_testing;
99 lock $plan if THREADSAFE;
107 my $level = 1 + ($Test::Builder::Level || 0);
108 my ($file, $line) = (caller $level)[1, 2];
109 warn @_, " at $file line $line.\n";
113 my $level = 1 + ($Test::Builder::Level || 0);
114 my ($file, $line) = (caller $level)[1, 2];
115 die @_, " at $file line $line.\n";
118 sub _sanitize_comment {
121 $_[0] =~ s/\n/\n# /g;
126 The following functions from L<Test::More> are implemented and exported by default.
128 =head2 C<< plan [ tests => $count | 'no_plan' | skip_all => $reason ] >>
133 my ($key, $value) = @_;
137 lock $plan if THREADSAFE;
139 croak("You tried to plan twice") if defined $plan;
143 if ($key eq 'no_plan') {
144 croak("no_plan takes no arguments") if $value;
146 } elsif ($key eq 'tests') {
147 croak("Got an undefined number of tests") unless defined $value;
148 croak("You said to run 0 tests") unless $value;
149 croak("Number of tests must be a positive integer. You gave it '$value'")
150 unless $value =~ /^\+?[0-9]+$/;
152 $plan_str = "1..$value";
153 } elsif ($key eq 'skip_all') {
155 $plan_str = '1..0 # SKIP';
156 if (defined $value) {
157 _sanitize_comment($value);
158 $plan_str .= " $value" if length $value;
161 my @args = grep defined, $key, $value;
162 croak("plan() doesn't understand @args");
165 if (defined $plan_str) {
167 print $TAP_STREAM "$plan_str\n";
170 exit 0 if $plan == SKIP_ALL;
202 if ($item eq 'import') {
203 push @imports, @{ $_[$i+1] };
205 } elsif ($item eq 'no_diag') {
206 lock $plan if THREADSAFE;
212 splice @_, $i, $splice;
219 local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
223 @_ = ($class, @imports);
224 goto &Exporter::import;
227 =head2 C<< skip $reason => $count >>
232 my ($reason, $count) = @_;
234 lock $plan if THREADSAFE;
236 if (not defined $count) {
237 carp("skip() needs to know \$how_many tests are in the block")
238 unless defined $plan and $plan == NO_PLAN;
240 } elsif ($count =~ /[^0-9]/) {
241 carp('skip() was passed a non-numeric number of tests. Did you get the arguments backwards?');
248 my $skip_str = "ok $test # skip";
249 if (defined $reason) {
250 _sanitize_comment($reason);
251 $skip_str .= " $reason" if length $reason;
255 print $TAP_STREAM "$skip_str\n";
258 no warnings 'exiting';
262 =head2 C<done_testing [ $count ]>
269 lock $plan if THREADSAFE;
271 $count = $test unless defined $count;
272 croak("Number of tests must be a positive integer. You gave it '$count'")
273 unless $count =~ /^\+?[0-9]+$/;
275 if (not defined $plan or $plan == NO_PLAN) {
276 $plan = $count; # $plan can't be NO_PLAN anymore
279 print $TAP_STREAM "1..$plan\n";
282 @_ = ('done_testing() was already called');
284 } elsif ($plan != $count) {
285 @_ = ("planned to run $plan tests but done_testing() expects $count");
293 =head2 C<ok $ok [, $desc ]>
298 my ($ok, $desc) = @_;
300 lock $plan if THREADSAFE;
304 my $test_str = "ok $test";
306 $test_str = "not $test_str";
310 _sanitize_comment($desc);
311 $test_str .= " - $desc" if length $desc;
315 print $TAP_STREAM "$test_str\n";
320 =head2 C<pass [ $desc ]>
329 =head2 C<fail [ $desc ]>
338 =head2 C<is $got, $expected [, $desc ]>
343 my ($got, $expected, $desc) = @_;
344 no warnings 'uninitialized';
346 (not(defined $got xor defined $expected) and $got eq $expected),
352 =head2 C<isnt $got, $expected [, $desc ]>
357 my ($got, $expected, $desc) = @_;
358 no warnings 'uninitialized';
360 ((defined $got xor defined $expected) or $got ne $expected),
372 ('//' => 'dor') x ($] >= 5.010),
397 ('~~' => 'smartmatch') x ($] >= 5.010),
409 '...' => 'altflipflop',
416 sub _create_binop_handler {
418 my $name = $binops{$op};
419 croak("Operator $op not supported") unless defined $name;
423 sub is_$name (\$\$;\$) {
424 my (\$got, \$expected, \$desc) = \@_;
425 \@_ = (scalar(\$got $op \$expected), \$desc);
431 $binop_handlers{$op} = do {
433 \&{__PACKAGE__."::is_$name"};
437 =head2 C<like $got, $regexp_expected [, $desc ]>
441 =head2 C<unlike $got, $regexp_expected, [, $desc ]>
447 *like = _create_binop_handler('=~');
448 *unlike = _create_binop_handler('!~');
451 =head2 C<cmp_ok $got, $op, $expected [, $desc ]>
456 my ($got, $op, $expected, $desc) = @_;
457 my $handler = $binop_handlers{$op};
459 local $Test::More::Level = ($Test::More::Level || 0) + 1;
460 $handler = _create_binop_handler($op);
462 @_ = ($got, $expected, $desc);
466 =head2 C<is_deeply $got, $expected [, $desc ]>
473 no warnings qw<numeric uninitialized>;
475 return 0 if defined($x) xor defined($y);
477 # Try object identity/eq overloading first. It also covers the case where
478 # $x and $y are both undefined.
479 # If either $x or $y is overloaded but none has eq overloading, the test will
480 # break at that point.
481 return 1 if not(ref($x) xor ref($y)) and $x eq $y;
483 # Test::More::is_deeply happily breaks encapsulation if the objects aren't
485 my $ry = Scalar::Util::reftype($y);
486 return 0 if Scalar::Util::reftype($x) ne $ry;
488 # Shortcut if $x and $y are both not references and failed the previous
492 if ($ry eq 'ARRAY') {
494 # Prevent vivification of deleted elements by fetching the array values.
496 _deep_check($ex = $x->[$_], $ey = $y->[$_]) or return 0 for 0 .. $#$x;
499 } elsif ($ry eq 'HASH') {
500 if (keys(%$x) == keys(%$y)) {
501 (exists $x->{$_} and _deep_check($x->{$_}, $y->{$_}))
502 or return 0 for keys %$y;
505 } elsif ($ry eq 'SCALAR' or $ry eq 'REF') {
506 return _deep_check($$x, $$y);
525 lock $plan if THREADSAFE;
528 my $msg = join '', map { defined($_) ? $_ : 'undef' } @_;
529 _sanitize_comment($msg);
530 return unless length $msg;
533 print $fh "# $msg\n";
543 unshift @_, $DIAG_STREAM;
552 unshift @_, $TAP_STREAM;
556 =head2 C<BAIL_OUT [ $desc ]>
563 lock $plan if THREADSAFE;
565 my $bail_out_str = 'Bail out!';
567 _sanitize_comment($desc);
568 $bail_out_str .= " $desc" if length $desc; # Two spaces
572 print $TAP_STREAM "$bail_out_str\n";
579 lock $plan if THREADSAFE;
583 $? = $failed <= 254 ? $failed : 254;
584 } elsif ($plan >= 0) {
585 $? = $test == $plan ? 0 : 255;
586 } elsif ($plan == NO_PLAN) {
588 print $TAP_STREAM "1..$test\n";
596 L<Test::Leaner> also provides some functions of its own, which are never exported.
598 =head2 C<tap_stream [ $fh ]>
600 Read/write accessor for the filehandle to which the tests are outputted.
601 On write, it also turns autoflush on onto C<$fh>.
603 Note that it can only be used as a write accessor before you start any thread, as L<threads::shared> cannot reliably share filehandles.
605 Defaults to C<STDOUT>.
609 sub tap_stream (;*) {
613 my $fh = select $TAP_STREAM;
623 =head2 C<diag_stream [ $fh ]>
625 Read/write accessor for the filehandle to which the diagnostics are printed.
626 On write, it also turns autoflush on onto C<$fh>.
628 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.
630 Defaults to C<STDERR>.
634 sub diag_stream (;*) {
636 $DIAG_STREAM = $_[0];
638 my $fh = select $DIAG_STREAM;
650 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>.
651 In that case, it also needs a working L<threads::shared>.
657 L<Exporter>, L<Scalar::Util>, L<Test::More>.
661 Vincent Pit, C<< <perl at profvince.com> >>, L<http://www.profvince.com>.
663 You can contact me by mail or on C<irc.perl.org> (vincent).
667 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>.
668 I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
672 You can find documentation for this module with the perldoc command.
676 =head1 COPYRIGHT & LICENSE
678 Copyright 2010 Vincent Pit, all rights reserved.
680 This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
684 1; # End of Test::Leaner