Initial Commit
This commit is contained in:
Riley Schneider
334
database/perl/lib/Test/Needs.pm
Normal file
334
database/perl/lib/Test/Needs.pm
Normal file
@@ -0,0 +1,334 @@
|
||||
package Test::Needs;
|
||||
use strict;
|
||||
use warnings;
|
||||
no warnings 'once';
|
||||
our $VERSION = '0.002006';
|
||||
$VERSION =~ tr/_//d;
|
||||
|
||||
BEGIN {
|
||||
*_WORK_AROUND_HINT_LEAKAGE
|
||||
= "$]" < 5.011 && !("$]" >= 5.009004 && "$]" < 5.010001)
|
||||
? sub(){1} : sub(){0};
|
||||
*_WORK_AROUND_BROKEN_MODULE_STATE
|
||||
= "$]" < 5.009
|
||||
? sub(){1} : sub(){0};
|
||||
}
|
||||
|
||||
our @EXPORT = qw(test_needs);
|
||||
|
||||
sub _try_require {
|
||||
local %^H
|
||||
if _WORK_AROUND_HINT_LEAKAGE;
|
||||
my ($module) = @_;
|
||||
(my $file = "$module.pm") =~ s{::|'}{/}g;
|
||||
my $err;
|
||||
{
|
||||
local $@;
|
||||
eval { require $file }
|
||||
or $err = $@;
|
||||
}
|
||||
if (defined $err) {
|
||||
delete $INC{$file}
|
||||
if _WORK_AROUND_BROKEN_MODULE_STATE;
|
||||
die $err
|
||||
unless $err =~ /\ACan't locate \Q$file\E/;
|
||||
return !1;
|
||||
}
|
||||
!0;
|
||||
}
|
||||
|
||||
sub _croak {
|
||||
my $message = join '', @_;
|
||||
my $i = 1;
|
||||
while (my ($p, $f, $l) = caller($i++)) {
|
||||
next
|
||||
if $p->isa(__PACKAGE__);
|
||||
die "$message at $f line $l.\n";
|
||||
}
|
||||
die $message;
|
||||
}
|
||||
|
||||
sub _try_version {
|
||||
my ($module, $version) = @_;
|
||||
local $@;
|
||||
!!eval { $module->VERSION($version); 1 };
|
||||
}
|
||||
|
||||
sub _numify_version {
|
||||
for ($_[0]) {
|
||||
return
|
||||
!$_ ? 0
|
||||
: /^[0-9]+\.[0-9]+$/ ? sprintf('%.6f', $_)
|
||||
: /^v?([0-9]+(?:\.[0-9]+)+)$/
|
||||
? sprintf('%d.%03d%03d', ((split /\./, $1), 0, 0)[0..2])
|
||||
: /^(\x05)(.*)$/s
|
||||
? sprintf('%d.%03d%03d', map ord, $1, split //, $2)
|
||||
: _croak qq{version "$_" does not look like a number};
|
||||
}
|
||||
}
|
||||
|
||||
sub _find_missing {
|
||||
my @bad = map {
|
||||
my ($module, $version) = @$_;
|
||||
$module eq 'perl' ? do {
|
||||
$version = _numify_version($version);
|
||||
"$]" < $version ? (sprintf "perl %s (have %.6f)", $version, $]) : ()
|
||||
}
|
||||
: $module =~ /^\d|[^\w:]|:::|[^:]:[^:]|^:|:$/
|
||||
? _croak sprintf qq{"%s" does not look like a module name}, $module
|
||||
: _try_require($module) ? (
|
||||
defined $version && !_try_version($module, $version)
|
||||
? "$module $version (have ".(defined $module->VERSION ? $module->VERSION : 'undef').')'
|
||||
: ()
|
||||
)
|
||||
: $version ? "$module $version"
|
||||
: $module;
|
||||
}
|
||||
_pairs(@_);
|
||||
@bad ? "Need " . join(', ', @bad) : undef;
|
||||
}
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
my $target = caller;
|
||||
if (@_) {
|
||||
local $Test::Builder::Level = ($Test::Builder::Level||0) + 1;
|
||||
test_needs(@_);
|
||||
}
|
||||
no strict 'refs';
|
||||
*{"${target}::$_"} = \&{"${class}::$_"}
|
||||
for @{"${class}::EXPORT"};
|
||||
}
|
||||
|
||||
sub test_needs {
|
||||
my $missing = _find_missing(@_);
|
||||
local $Test::Builder::Level = ($Test::Builder::Level||0) + 1;
|
||||
if ($missing) {
|
||||
if ($ENV{RELEASE_TESTING}) {
|
||||
_fail("$missing due to RELEASE_TESTING");
|
||||
}
|
||||
else {
|
||||
_skip($missing);
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub _skip { _fail_or_skip($_[0], 0) }
|
||||
sub _fail { _fail_or_skip($_[0], 1) }
|
||||
|
||||
sub _pairs {
|
||||
map +(
|
||||
ref eq 'HASH' ? do {
|
||||
my $arg = $_;
|
||||
map [ $_ => $arg->{$_} ], sort keys %$arg;
|
||||
}
|
||||
: ref eq 'ARRAY' ? do {
|
||||
my $arg = $_;
|
||||
map [ @{$arg}[$_*2,$_*2+1] ], 0 .. int($#$arg / 2);
|
||||
}
|
||||
: [ $_ ]
|
||||
), @_;
|
||||
}
|
||||
|
||||
sub _fail_or_skip {
|
||||
my ($message, $fail) = @_;
|
||||
if ($INC{'Test2/API.pm'}) {
|
||||
my $ctx = Test2::API::context();
|
||||
my $hub = $ctx->hub;
|
||||
if ($fail) {
|
||||
$ctx->ok(0, "Test::Needs modules available", [$message]);
|
||||
}
|
||||
else {
|
||||
my $plan = $hub->plan;
|
||||
my $tests = $hub->count;
|
||||
if ($plan || $tests) {
|
||||
my $skips
|
||||
= $plan && $plan ne 'NO PLAN' ? $plan - $tests : 1;
|
||||
$ctx->skip("Test::Needs modules not available") for 1 .. $skips;
|
||||
$ctx->note($message);
|
||||
}
|
||||
else {
|
||||
$ctx->plan(0, 'SKIP', $message);
|
||||
}
|
||||
}
|
||||
$ctx->done_testing;
|
||||
$ctx->release if $Test2::API::VERSION < 1.302053;
|
||||
$ctx->send_event('+'._t2_terminate_event());
|
||||
}
|
||||
elsif ($INC{'Test/Builder.pm'}) {
|
||||
my $tb = Test::Builder->new;
|
||||
my $has_plan = Test::Builder->can('has_plan') ? 'has_plan'
|
||||
: sub { $_[0]->expected_tests || eval { $_[0]->current_test($_[0]->current_test); 'no_plan' } };
|
||||
if ($fail) {
|
||||
$tb->plan(tests => 1)
|
||||
unless $tb->$has_plan;
|
||||
$tb->ok(0, "Test::Needs modules available");
|
||||
$tb->diag($message);
|
||||
}
|
||||
else {
|
||||
my $plan = $tb->$has_plan;
|
||||
my $tests = $tb->current_test;
|
||||
if ($plan || $tests) {
|
||||
my $skips
|
||||
= $plan && $plan ne 'no_plan' ? $plan - $tests : 1;
|
||||
$tb->skip("Test::Needs modules not available")
|
||||
for 1 .. $skips;
|
||||
Test::Builer->can('note') ? $tb->note($message) : print "# $message\n";
|
||||
}
|
||||
else {
|
||||
$tb->skip_all($message);
|
||||
}
|
||||
}
|
||||
$tb->done_testing
|
||||
if Test::Builder->can('done_testing');
|
||||
die bless {} => 'Test::Builder::Exception'
|
||||
if Test::Builder->can('parent') && $tb->parent;
|
||||
}
|
||||
else {
|
||||
if ($fail) {
|
||||
print "1..1\n";
|
||||
print "not ok 1 - Test::Needs modules available\n";
|
||||
print STDERR "# $message\n";
|
||||
exit 1;
|
||||
}
|
||||
else {
|
||||
print "1..0 # SKIP $message\n";
|
||||
}
|
||||
}
|
||||
exit 0;
|
||||
}
|
||||
|
||||
my $terminate_event;
|
||||
sub _t2_terminate_event () {
|
||||
return $terminate_event
|
||||
if $terminate_event;
|
||||
local $@;
|
||||
my $file = __FILE__;
|
||||
$terminate_event = eval <<"END_CODE" or die "$@";
|
||||
package # hide
|
||||
Test::Needs::Event::Terminate;
|
||||
use Test2::Event ();
|
||||
our \@ISA = qw(Test2::Event);
|
||||
sub no_display { 1 }
|
||||
sub terminate { 0 }
|
||||
\$INC{'Test/Needs/Event/Terminate.pm'} = \$file;
|
||||
__PACKAGE__;
|
||||
END_CODE
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding utf-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Needs - Skip tests when modules not available
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# need one module
|
||||
use Test::Needs 'Some::Module';
|
||||
|
||||
# need multiple modules
|
||||
use Test::Needs 'Some::Module', 'Some::Other::Module';
|
||||
|
||||
# need a given version of a module
|
||||
use Test::Needs {
|
||||
'Some::Module' => '1.005',
|
||||
};
|
||||
|
||||
# check later
|
||||
use Test::Needs;
|
||||
test_needs 'Some::Module';
|
||||
|
||||
# skips remainder of subtest
|
||||
use Test::More;
|
||||
use Test::Needs;
|
||||
subtest 'my subtest' => sub {
|
||||
test_needs 'Some::Module';
|
||||
...
|
||||
};
|
||||
|
||||
# check perl version
|
||||
use Test::Needs { perl => 5.020 };
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Skip test scripts if modules are not available. The requested modules will be
|
||||
loaded, and optionally have their versions checked. If the module is missing,
|
||||
the test script will be skipped. Modules that are found but fail to compile
|
||||
will exit with an error rather than skip.
|
||||
|
||||
If used in a subtest, the remainder of the subtest will be skipped.
|
||||
|
||||
Skipping will work even if some tests have already been run, or if a plan has
|
||||
been declared.
|
||||
|
||||
Versions are checked via a C<< $module->VERSION($wanted_version) >> call.
|
||||
Versions must be provided in a format that will be accepted. No extra
|
||||
processing is done on them.
|
||||
|
||||
If C<perl> is used as a module, the version is checked against the running perl
|
||||
version (L<$]|perlvar/$]>). The version can be specified as a number,
|
||||
dotted-decimal string, v-string, or version object.
|
||||
|
||||
If the C<RELEASE_TESTING> environment variable is set, the tests will fail
|
||||
rather than skip. Subtests will be aborted, but the test script will continue
|
||||
running after that point.
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
=head2 test_needs
|
||||
|
||||
Has the same interface as when using Test::Needs in a C<use>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<Test::Requires>
|
||||
|
||||
A similar module, with some important differences. L<Test::Requires> will act
|
||||
as a C<use> statement (despite its name), calling the import sub. Under
|
||||
C<RELEASE_TESTING>, it will BAIL_OUT if a module fails to load rather than
|
||||
using a normal test fail. It also doesn't distinguish between missing modules
|
||||
and broken modules.
|
||||
|
||||
=item L<Test2::Require::Module>
|
||||
|
||||
Part of the L<Test2> ecosystem. Only supports running as a C<use> command to
|
||||
skip an entire plan.
|
||||
|
||||
=item L<Test2::Require::Perl>
|
||||
|
||||
Part of the L<Test2> ecosystem. Only supports running as a C<use> command to
|
||||
skip an entire plan. Checks perl versions.
|
||||
|
||||
=item L<Test::If>
|
||||
|
||||
Acts as a C<use> statement. Only supports running as a C<use> command to skip
|
||||
an entire plan. Can skip based on subref results.
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
haarg - Graham Knop (cpan:HAARG) <haarg@haarg.org>
|
||||
|
||||
=head1 CONTRIBUTORS
|
||||
|
||||
None so far.
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (c) 2016 the Test::Needs L</AUTHORS> and L</CONTRIBUTORS>
|
||||
as listed above.
|
||||
|
||||
This library is free software and may be distributed under the same terms
|
||||
as perl itself. See L<http://dev.perl.org/licenses/>.
|
||||
|
||||
=cut
|
||||
Reference in New Issue
Block a user