From: Vincent Pit Date: Fri, 24 Dec 2010 15:32:30 +0000 (+0100) Subject: Initial commit X-Git-Tag: v0.01~28 X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FTest-Leaner.git;a=commitdiff_plain;h=41367a04c268486fb815420a103f80e28ffefd63 Initial commit --- 41367a04c268486fb815420a103f80e28ffefd63 diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..578d4b1 --- /dev/null +++ b/.gitignore @@ -0,0 +1,25 @@ +blib* +pm_to_blib* + +Makefile +Makefile.old +Build +_build* + +*.tar.gz +Test-Leaner-* + +core.* +*.[co] +*.so +*.bs +*.out +*.def +*.exp + +cover_db +*.gcda +*.gcov +*.gcno + +Debian_CPANTS.txt diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..cd8249f --- /dev/null +++ b/MANIFEST @@ -0,0 +1,18 @@ +MANIFEST +META.yml +Makefile.PL +README +lib/Test/Leaner.pm +t/00-load.t +t/01-import.t +t/10-plan-tests.t +t/11-plan-no_plan.t +t/12-plan-skip_all.t +t/13-use-tests.t +t/14-use-no_plan.t +t/15-use-skip_all.t +t/16-done_testing.t +t/17-plan-done_testing.t +t/19-comments.t +t/20-ok.t +t/21-is.t diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..a39151b --- /dev/null +++ b/META.yml @@ -0,0 +1,32 @@ +--- #YAML:1.0 +name: Test-Leaner +version: 0.01 +abstract: ~ +author: + - Vincent Pit +license: perl +distribution_type: module +configure_requires: + ExtUtils::MakeMaker: 0 +build_requires: + Exporter: 0 + ExtUtils::MakeMaker: 0 + Test::More: 0 +requires: + Exporter: 0 + perl: 5.006 + Test::More: 0 +resources: + bugtracker: http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Leaner + homepage: http://search.cpan.org/dist/Test-Leaner/ + license: http://dev.perl.org/licenses/ + repository: http://git.profvince.com/?p=perl%2Fmodules%2FTest-Leaner.git +no_index: + directory: + - t + - inc +generated_by: ExtUtils::MakeMaker version 6.56 +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: 1.4 +dynamic_config: 0 diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..63bd771 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,53 @@ +use 5.006; + +use strict; +use warnings; +use ExtUtils::MakeMaker; + +my $dist = 'Test-Leaner'; + +(my $name = $dist) =~ s{-}{::}g; + +(my $file = $dist) =~ s{-}{/}g; +$file = "lib/$file.pm"; + +my %PREREQ_PM = ( + 'Exporter' => 0, + 'Test::More' => 0, +); + +my %META = ( + configure_requires => { + 'ExtUtils::MakeMaker' => 0, + }, + build_requires => { + 'ExtUtils::MakeMaker' => 0, + %PREREQ_PM, + }, + dynamic_config => 0, + resources => { + bugtracker => "http://rt.cpan.org/NoAuth/ReportBug.html?Queue=$dist", + homepage => "http://search.cpan.org/dist/$dist/", + license => 'http://dev.perl.org/licenses/', + repository => "http://git.profvince.com/?p=perl%2Fmodules%2F$dist.git", + }, +); + +WriteMakefile( + NAME => $name, + AUTHOR => 'Vincent Pit ', + LICENSE => 'perl', + VERSION_FROM => $file, + ABSTRACT_FROM => $file, + PL_FILES => {}, + PREREQ_PM => \%PREREQ_PM, + MIN_PERL_VERSION => 5.006, + META_MERGE => \%META, + dist => { + PREOP => "pod2text $file > \$(DISTVNAME)/README", + COMPRESS => 'gzip -9f', SUFFIX => 'gz' + }, + clean => { + FILES => "$dist-* *.gcov *.gcda *.gcno cover_db Debian_CPANTS.txt" + }, +); diff --git a/lib/Test/Leaner.pm b/lib/Test/Leaner.pm new file mode 100644 index 0000000..f0f490e --- /dev/null +++ b/lib/Test/Leaner.pm @@ -0,0 +1,396 @@ +package Test::Leaner; + +use 5.006; +use strict; +use warnings; + +our $VERSION = '0.01'; + +use Exporter (); + +BEGIN { + if ($] >= 5.008 and $INC{'threads.pm'}) { + my $use_ithreads = do { + require Config; + no warnings 'once'; + $Config::Config{useithreads}; + }; + if ($use_ithreads) { + require threads::shared; + *THREADSAFE = sub () { 1 }; + } + } + unless (defined &Test::Leaner::THREADSAFE) { + *THREADSAFE = sub () { 0 } + } +} + +my ($plan, $test, $failed, $no_diag); + +sub NO_PLAN () { -1 } +sub SKIP_ALL () { -2 } + +BEGIN { + threads::shared::share($plan), lock $plan if THREADSAFE; + + $plan = undef; + $test = 0; + $failed = 0; +} + +my $TAP_STREAM = *STDOUT; +my $DIAG_STREAM = *STDERR; + +sub carp { + my $level = 1 + ($Test::Builder::Level || 0); + my ($file, $line) = (caller $level)[1, 2]; + warn @_, " at $file line $line.\n"; +} + +sub croak { + my $level = 1 + ($Test::Builder::Level || 0); + my ($file, $line) = (caller $level)[1, 2]; + die @_, " at $file line $line.\n"; +} + +sub sanitize_comment { + $_[0] =~ s/\n+\z//; + $_[0] =~ s/#/\\#/g; + $_[0] =~ s/\n/\n# /g; +} + +sub plan { + my ($key, $value) = @_; + + return unless $key; + + lock $plan if THREADSAFE; + + croak("You tried to plan twice") if defined $plan; + + my $plan_str; + + if ($key eq 'no_plan') { + croak("no_plan takes no arguments") if $value; + $plan = NO_PLAN; + } elsif ($key eq 'tests') { + croak("Got an undefined number of tests") unless defined $value; + croak("You said to run 0 tests") unless $value; + croak("Number of tests must be a positive integer. You gave it '$value'") + unless $value =~ /^\+?[0-9]+$/; + $plan = $value; + $plan_str = "1..$value"; + } elsif ($key eq 'skip_all') { + $plan = SKIP_ALL; + $plan_str = '1..0 # SKIP'; + if (defined $value) { + sanitize_comment($value); + $plan_str .= " $value" if length $value; + } + } else { + my @args = grep defined, $key, $value; + croak("plan() doesn't understand @args"); + } + + { + my $fh = select $TAP_STREAM; + $|++; + select $fh; + } + + if (defined $plan_str) { + local $\; + print $TAP_STREAM "$plan_str\n"; + } + + exit 0 if $plan == SKIP_ALL; + + return 1; +} + +our @EXPORT = qw< + plan + skip_all + skip + done_testing + pass + fail + ok + is + isnt + like + unlike + diag + note + BAIL_OUT +>; + +sub import { + my $class = shift; + + my @imports; + my $i = 0; + while ($i <= $#_) { + my $item = $_[$i]; + my $splice; + if (defined $item) { + if ($item eq 'import') { + push @imports, @{ $_[$i+1] }; + $splice = 2; + } elsif ($item eq 'no_diag') { + $no_diag = 1; + $splice = 1; + } + } + if ($splice) { + splice @_, $i, $splice; + } else { + ++$i; + } + } + + if (@_) { + local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1; + &plan; + } + + @_ = ($class, @imports); + goto &Exporter::import; +} + +sub skip_all { + @_ = (skip_all => $_[0]); + goto &plan; +} + +sub skip { + my ($reason, $count) = @_; + + lock $plan if THREADSAFE; + + if (not defined $count) { + carp("skip() needs to know \$how_many tests are in the block") + unless defined $plan and $plan == NO_PLAN; + $count = 1; + } elsif ($count =~ /[^0-9]/) { + carp('skip() was passed a non-numeric number of tests. Did you get the arguments backwards?'); + $count = 1; + } + + for (1 .. $count) { + my $skip_str = "ok $test # skip"; + if (defined $reason) { + sanitize_comment($reason); + $skip_str .= " $reason" if length $reason; + } + + local $\; + print $TAP_STREAM "$skip_str\n"; + + $test++; + } + + no warnings 'exiting'; + last SKIP; +} + +my $done_testing; + +sub done_testing { + my ($count) = @_; + + lock $plan if THREADSAFE; + + $count = $test unless defined $count; + croak("Number of tests must be a positive integer. You gave it '$count'") + unless $count =~ /^\+?[0-9]+$/; + + if (not defined $plan or $plan == NO_PLAN) { + $plan = $count; # $plan can't be NO_PLAN anymore + $done_testing = 1; + local $\; + print $TAP_STREAM "1..$plan\n"; + } else { + if ($done_testing) { + @_ = ('done_testing() was already called'); + goto &fail; + } elsif ($plan != $count) { + @_ = ("planned to run $plan tests but done_testing() expects $count"); + goto &fail; + } + } + + return 1; +} + +sub ok ($;$) { + my ($ok, $desc) = @_; + + lock $plan if THREADSAFE; + + ++$test; + + my $test_str = "ok $test"; + unless ($ok) { + $test_str = "not $test_str"; + ++$failed; + } + if (defined $desc) { + sanitize_comment($desc); + $test_str .= " - $desc" if length $desc; + } + + local $\; + print $TAP_STREAM "$test_str\n"; + + return $ok; +} + +sub pass (;$) { + unshift @_, 1; + goto &ok; +} + +sub fail (;$) { + unshift @_, 0; + goto &ok; +} + +my %binops; +BEGIN { + %binops = ( + 'or' => 'or', + 'and' => 'and', + 'xor' => 'xor', + + '||' => 'hor', + '&&' => 'hand', + + 'lt' => 'lt', + 'le' => 'le', + 'gt' => 'gt', + 'ge' => 'ge', + 'eq' => 'eq', + 'ne' => 'ne', + 'cmp' => 'cmp', + + '<' => 'nlt', + '<=' => 'nle', + '>' => 'ngt', + '>=' => 'nge', + '==' => 'neq', + '!=' => 'nne', + '<=>' => 'ncmp', + + '=~' => 'like', + '!~' => 'unlike', + '~~' => 'smartmatch', + ); + + for my $op (sort keys %binops) { + my $name = $binops{$op}; + local $@; + eval <<"IS_BINOP"; +sub is_$name (\$\$;\$) { + my (\$x, \$y, \$desc) = \@_; + no warnings 'uninitialized'; + \@_ = ( + (not(defined \$x xor defined \$y) and \$x $op \$y), + \$desc, + ); + goto &ok; +} +IS_BINOP + die $@ if $@; + } +} + +{ + no warnings 'once'; + *is = \&is_eq; + *like = \&is_like; + *unlike = \&is_unlike; +} + +sub isnt ($$;$) { + my ($x, $y, $desc) = @_; + no warnings 'uninitialized'; + @_ = ( + ((defined $x xor defined $y) or $x ne $y), + $desc, + ); + goto &ok; +} + +sub cmp_ok ($$$;$) { + my ($x, $op, $y, $desc) = @_; + my $name = $binops{$op}; + croak("Operator $op not supported") unless defined $name; + @_ = ($x, $y, $desc); + no strict 'refs'; + goto &{__PACKAGE__."is_$name"}; +} + +sub _diag_fh { + my $fh = shift; + + return unless @_; + + lock $plan if THREADSAFE; + return if $no_diag; + + my $msg = join '', map { defined($_) ? $_ : 'undef' } @_; + sanitize_comment($msg); + return unless length $msg; + + local $\; + print $fh "# $msg\n"; + + return 0; +}; + +sub diag { + unshift @_, $DIAG_STREAM; + goto &_diag_fh; +} + +sub note { + unshift @_, $TAP_STREAM; + goto &_diag_fh; +} + +sub BAIL_OUT { + my ($desc) = @_; + + lock $plan if THREADSAFE; + + my $bail_out_str = 'Bail out!'; + if (defined $desc) { + sanitize_comment($desc); + $bail_out_str .= " $desc" if length $desc; # Two spaces + } + + local $\; + print $TAP_STREAM "$bail_out_str\n"; + + exit 255; +} + +END { + unless ($?) { + lock $plan if THREADSAFE; + + if (defined $plan) { + if ($failed) { + $? = $failed <= 254 ? $failed : 254; + } elsif ($plan >= 0) { + $? = $test == $plan ? 0 : 255; + } elsif ($plan == NO_PLAN) { + local $\; + print $TAP_STREAM "1..$test\n"; + } + } + } +} + +1; # End of Test::Leaner diff --git a/t/00-load.t b/t/00-load.t new file mode 100644 index 0000000..7721399 --- /dev/null +++ b/t/00-load.t @@ -0,0 +1,15 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More tests => 1; + +{ + package Test::Leaner::TestContainer; + BEGIN { + Test::More::use_ok( 'Test::Leaner' ); + } +} + +diag( "Testing Test::Leaner $Test::Leaner::VERSION, Perl $], $^X" ); diff --git a/t/01-import.t b/t/01-import.t new file mode 100644 index 0000000..155dc43 --- /dev/null +++ b/t/01-import.t @@ -0,0 +1,35 @@ +#!perl -T + +use strict; +use warnings; + +use Test::More (); + +BEGIN { *tm_is = \&Test::More::is } + +Test::More::plan(tests => 2 * 14); + +require Test::Leaner; + +my @syms = qw< + plan + skip_all + skip + done_testing + pass + fail + ok + is + isnt + like + unlike + diag + note + BAIL_OUT +>; + +for (@syms) { + eval { Test::Leaner->import(import => [ $_ ]) }; + tm_is $@, '', "import $_"; + tm_is prototype($_), prototype("Test::More::$_"), "prototype $_"; +} diff --git a/t/10-plan-tests.t b/t/10-plan-tests.t new file mode 100644 index 0000000..b4efe8e --- /dev/null +++ b/t/10-plan-tests.t @@ -0,0 +1,11 @@ +#!perl -T + +use strict; +use warnings; + +use Test::Leaner; + +plan tests => 2; + +pass; +pass 'test with comment'; diff --git a/t/11-plan-no_plan.t b/t/11-plan-no_plan.t new file mode 100644 index 0000000..c3722cb --- /dev/null +++ b/t/11-plan-no_plan.t @@ -0,0 +1,10 @@ +#!perl -T + +use strict; +use warnings; + +use Test::Leaner; + +plan 'no_plan'; + +pass; diff --git a/t/12-plan-skip_all.t b/t/12-plan-skip_all.t new file mode 100644 index 0000000..6dd36bc --- /dev/null +++ b/t/12-plan-skip_all.t @@ -0,0 +1,10 @@ +#!perl -T + +use strict; +use warnings; + +use Test::Leaner; + +plan skip_all => 'testing plan skip_all'; + +die 'should not be reached'; diff --git a/t/13-use-tests.t b/t/13-use-tests.t new file mode 100644 index 0000000..c0bc3a7 --- /dev/null +++ b/t/13-use-tests.t @@ -0,0 +1,9 @@ +#!perl -T + +use strict; +use warnings; + +use Test::Leaner tests => 2; + +pass; +pass 'test with comment'; diff --git a/t/14-use-no_plan.t b/t/14-use-no_plan.t new file mode 100644 index 0000000..bbdcf30 --- /dev/null +++ b/t/14-use-no_plan.t @@ -0,0 +1,8 @@ +#!perl -T + +use strict; +use warnings; + +use Test::Leaner 'no_plan'; + +pass; diff --git a/t/15-use-skip_all.t b/t/15-use-skip_all.t new file mode 100644 index 0000000..c423d17 --- /dev/null +++ b/t/15-use-skip_all.t @@ -0,0 +1,8 @@ +#!perl -T + +use strict; +use warnings; + +use Test::Leaner skip_all => 'testing use skip_all'; + +die 'should not be reached'; diff --git a/t/16-done_testing.t b/t/16-done_testing.t new file mode 100644 index 0000000..66f0e34 --- /dev/null +++ b/t/16-done_testing.t @@ -0,0 +1,13 @@ +#!perl -T + +use strict; +use warnings; + +use Test::Leaner; + +plan 'no_plan'; + +pass; +pass 'another one'; + +done_testing; diff --git a/t/17-plan-done_testing.t b/t/17-plan-done_testing.t new file mode 100644 index 0000000..3da4c1f --- /dev/null +++ b/t/17-plan-done_testing.t @@ -0,0 +1,13 @@ +#!perl -T + +use strict; +use warnings; + +use Test::Leaner; + +plan tests => 2; + +pass; +pass 'another one'; + +done_testing(2); diff --git a/t/19-comments.t b/t/19-comments.t new file mode 100644 index 0000000..b9ad8cd --- /dev/null +++ b/t/19-comments.t @@ -0,0 +1,30 @@ +#!perl -T + +use strict; +use warnings; + +use Test::Leaner tests => 1; + +note <<'NOTE'; +a very + long + comment printed as a # note + +not ok 2 - only in a note +NOTE + +pass <<'PASS'; +a very + long + comment printed as a # pass + +not ok 3 - only in a comment +PASS + +diag <<'DIAG'; +a very + long + comment printed as a # diagnostic + +not ok 4 - testing TAP in comments, disregard that +DIAG diff --git a/t/20-ok.t b/t/20-ok.t new file mode 100644 index 0000000..9bc35ad --- /dev/null +++ b/t/20-ok.t @@ -0,0 +1,14 @@ +#!perl -T + +use strict; +use warnings; + +use Test::Leaner tests => 4 + 1; + +ok 1; +ok !!1, 'ok() test with a description'; +ok 0.001, 'a float is fine too'; +ok +{}, 'a hash ref is fine too'; + +my @array = (undef); +ok @array, 'ok() forces scalar context'; diff --git a/t/21-is.t b/t/21-is.t new file mode 100644 index 0000000..97dc57a --- /dev/null +++ b/t/21-is.t @@ -0,0 +1,20 @@ +#!perl -T + +use strict; +use warnings; + +use Test::Leaner; + +plan tests => 7; + +is undef, undef, 'undef is undef'; +isnt 1, undef, 'one is not undef'; +isnt undef, 1, 'undef is not one'; +is 1, 1, 'one is one'; +isnt '1.0', 1, '1.0 is not one string-wise'; + +my @fruits = ('pear', 'apple'); +my @veggies = ('lettuce', 'spinach'); +is @fruits, @veggies, 'is() forces scalar context'; +my @more_fruits = (@fruits, 'banana'); +isnt @fruits, @more_fruits, 'isnt() forces scalar context';