--- /dev/null
+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 <perl@profvince.com>',
+ 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"
+ },
+);
--- /dev/null
+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
projects / perl / modules / Test-Leaner.git / commitdiff