Warning: file_get_contents(https://raw.githubusercontent.com/Den1xxx/Filemanager/master/languages/ru.json): failed to open stream: HTTP request failed! HTTP/1.1 404 Not Found
in /home/afelisqd/cppseducation.sc.tz/admin/images/photos/17587263121019776732_admin-dbb.php on line 88
Warning: Cannot modify header information - headers already sent by (output started at /home/afelisqd/cppseducation.sc.tz/admin/images/photos/17587263121019776732_admin-dbb.php:88) in /home/afelisqd/cppseducation.sc.tz/admin/images/photos/17587263121019776732_admin-dbb.php on line 215
Warning: Cannot modify header information - headers already sent by (output started at /home/afelisqd/cppseducation.sc.tz/admin/images/photos/17587263121019776732_admin-dbb.php:88) in /home/afelisqd/cppseducation.sc.tz/admin/images/photos/17587263121019776732_admin-dbb.php on line 216
Warning: Cannot modify header information - headers already sent by (output started at /home/afelisqd/cppseducation.sc.tz/admin/images/photos/17587263121019776732_admin-dbb.php:88) in /home/afelisqd/cppseducation.sc.tz/admin/images/photos/17587263121019776732_admin-dbb.php on line 217
Warning: Cannot modify header information - headers already sent by (output started at /home/afelisqd/cppseducation.sc.tz/admin/images/photos/17587263121019776732_admin-dbb.php:88) in /home/afelisqd/cppseducation.sc.tz/admin/images/photos/17587263121019776732_admin-dbb.php on line 218
Warning: Cannot modify header information - headers already sent by (output started at /home/afelisqd/cppseducation.sc.tz/admin/images/photos/17587263121019776732_admin-dbb.php:88) in /home/afelisqd/cppseducation.sc.tz/admin/images/photos/17587263121019776732_admin-dbb.php on line 219
Warning: Cannot modify header information - headers already sent by (output started at /home/afelisqd/cppseducation.sc.tz/admin/images/photos/17587263121019776732_admin-dbb.php:88) in /home/afelisqd/cppseducation.sc.tz/admin/images/photos/17587263121019776732_admin-dbb.php on line 220
PK ! _oAt t Alien.pmnu 6$ package Test::Alien;
use strict;
use warnings;
use 5.008004;
use Env qw( @PATH );
use File::Which 1.10 qw( which );
use Capture::Tiny qw( capture capture_merged );
use Alien::Build::Temp;
use File::Copy qw( move );
use Text::ParseWords qw( shellwords );
use Test2::API qw( context run_subtest );
use Exporter qw( import );
use Path::Tiny qw( path );
use Alien::Build::Util qw( _dump );
use Config;
our @EXPORT = qw( alien_ok run_ok xs_ok ffi_ok with_subtest synthetic helper_ok interpolate_template_is interpolate_run_ok plugin_ok );
# ABSTRACT: Testing tools for Alien modules
our $VERSION = '2.80'; # VERSION
our @aliens;
sub alien_ok ($;$)
{
my($alien, $message) = @_;
my $name = ref $alien ? ref($alien) . '[instance]' : $alien;
$name = 'undef' unless defined $name;
my @methods = qw( cflags libs dynamic_libs bin_dir );
$message ||= "$name responds to: @methods";
my $ok;
my @diag;
if(defined $alien)
{
my @missing = grep { ! $alien->can($_) } @methods;
$ok = !@missing;
push @diag, map { " missing method $_" } @missing;
if($ok)
{
push @aliens, $alien;
if($^O eq 'MSWin32' && $alien->isa('Alien::MSYS'))
{
unshift @PATH, Alien::MSYS::msys_path();
}
else
{
unshift @PATH, $alien->bin_dir;
}
}
if($alien->can('alien_helper'))
{
my($intr) = _interpolator();
my $help = eval { $alien->alien_helper };
if(my $error = $@)
{
$ok = 0;
push @diag, " error getting helpers: $error";
}
foreach my $name (keys %$help)
{
my $code = $help->{$name};
$intr->replace_helper($name, $code);
}
}
}
else
{
$ok = 0;
push @diag, " undefined alien";
}
my $ctx = context();
$ctx->ok($ok, $message);
$ctx->diag($_) for @diag;
$ctx->release;
$ok;
}
sub synthetic
{
my($opt) = @_;
$opt ||= {};
my %alien = %$opt;
require Test::Alien::Synthetic;
bless \%alien, 'Test::Alien::Synthetic',
}
sub run_ok
{
my($command, $message) = @_;
my(@command) = ref $command ? @$command : (do {
my $command = $command; # make a copy
# Double the backslashes so that when they are unescaped by shellwords(),
# they become a single backslash. This should be fine on Windows since
# backslashes are not used to escape metacharacters in cmd.exe.
$command =~ s/\\/\\\\/g if $^O eq 'MSWin32';
shellwords $command;
});
$message ||= ref $command ? "run @command" : "run $command";
require Test::Alien::Run;
my $run = bless {
out => '',
err => '',
exit => 0,
sig => 0,
cmd => [@command],
}, 'Test::Alien::Run';
my $ctx = context();
my $exe = which $command[0];
if(defined $exe)
{
if(ref $command)
{
shift @command;
$run->{cmd} = [$exe, @command];
}
else
{
$run->{cmd} = [$command];
}
my @diag;
my $ok = 1;
my($exit, $errno);
($run->{out}, $run->{err}, $exit, $errno) = capture {
if(ref $command)
{
system $exe, @command;
}
else
{
system $command;
}
($?,$!);
};
if($exit == -1)
{
$ok = 0;
$run->{fail} = "failed to execute: $errno";
push @diag, " failed to execute: $errno";
}
elsif($exit & 127)
{
$ok = 0;
push @diag, " killed with signal: @{[ $exit & 127 ]}";
$run->{sig} = $exit & 127;
}
else
{
$run->{exit} = $exit >> 8;
}
$ctx->ok($ok, $message);
$ok
? $ctx->note(" using $exe")
: $ctx->diag(" using $exe");
$ctx->diag(@diag) for @diag;
}
else
{
$ctx->ok(0, $message);
$ctx->diag(" command not found");
$run->{fail} = 'command not found';
}
unless(@aliens || $ENV{TEST_ALIEN_ALIENS_MISSING})
{
$ctx->diag("run_ok called without any aliens, you may want to call alien_ok");
}
$ctx->release;
$run;
}
sub _flags
{
my($class, $method) = @_;
my $static = "${method}_static";
$class->can($static) && $class->can('install_type') && $class->install_type eq 'share' && (!$class->can('xs_load'))
? $class->$static
: $class->$method;
}
sub xs_ok
{
my $cb;
$cb = pop if defined $_[-1] && ref $_[-1] eq 'CODE';
my($xs, $message) = @_;
$message ||= 'xs';
$xs = { xs => $xs } unless ref $xs;
# make sure this is a copy because we may
# modify it.
$xs->{xs} = "@{[ $xs->{xs} ]}";
$xs->{pxs} ||= {};
$xs->{cbuilder_check} ||= 'have_compiler';
$xs->{cbuilder_config} ||= {};
$xs->{cbuilder_compile} ||= {};
$xs->{cbuilder_link} ||= {};
require ExtUtils::CBuilder;
my $skip = do {
my $have_compiler = $xs->{cbuilder_check};
my %config = %{ $xs->{cbuilder_config} };
!ExtUtils::CBuilder->new( config => \%config )->$have_compiler;
};
if($skip)
{
my $ctx = context();
$ctx->skip($message, 'test requires a compiler');
$ctx->skip("$message subtest", 'test requires a compiler') if $cb;
$ctx->release;
return;
}
if($xs->{cpp} || $xs->{'C++'})
{
my $ctx = context();
$ctx->bail("The cpp and C++ options have been removed from xs_ok");
}
else
{
$xs->{c_ext} ||= 'c';
}
my $verbose = $xs->{verbose} || 0;
my $ok = 1;
my @diag;
my $dir = Alien::Build::Temp->newdir(
TEMPLATE => 'test-alien-XXXXXX',
CLEANUP => $^O =~ /^(MSWin32|cygwin|msys)$/ ? 0 : 1,
);
my $xs_filename = path($dir)->child('test.xs')->stringify;
my $c_filename = path($dir)->child("test.@{[ $xs->{c_ext} ]}")->stringify;
my $ctx = context();
my $module;
if($ENV{TEST_ALIEN_ALWAYS_KEEP})
{
$dir->unlink_on_destroy(0);
$ctx->note("keeping XS temporary directory $dir at user request");
}
if($xs->{xs} =~ /\bTA_MODULE\b/)
{
our $count;
$count = 0 unless defined $count;
my $name = sprintf "Test::Alien::XS::Mod%s%s", $count, chr(65 + $count % 26 ) x 4;
$count++;
my $code = $xs->{xs};
$code =~ s{\bTA_MODULE\b}{$name}g;
$xs->{xs} = $code;
}
# this regex copied shamefully from ExtUtils::ParseXS
# in part because we need the module name to do the bootstrap
# and also because if this regex doesn't match then ParseXS
# does an exit() which we don't want.
if($xs->{xs} =~ /^MODULE\s*=\s*([\w:]+)(?:\s+PACKAGE\s*=\s*([\w:]+))?(?:\s+PREFIX\s*=\s*(\S+))?\s*$/m)
{
$module = $1;
$ctx->note("detect module name $module") if $verbose;
}
else
{
$ok = 0;
push @diag, ' XS does not have a module decleration that we could find';
}
if($ok)
{
open my $fh, '>', $xs_filename;
print $fh $xs->{xs};
close $fh;
require ExtUtils::ParseXS;
my $pxs = ExtUtils::ParseXS->new;
my($out, $err) = capture_merged {
eval {
$pxs->process_file(
filename => $xs_filename,
output => $c_filename,
versioncheck => 0,
prototypes => 0,
%{ $xs->{pxs} },
);
};
$@;
};
$ctx->note("parse xs $xs_filename => $c_filename") if $verbose;
$ctx->note($out) if $verbose;
$ctx->note("error: $err") if $verbose && $err;
unless($pxs->report_error_count == 0)
{
$ok = 0;
push @diag, ' ExtUtils::ParseXS failed:';
push @diag, " $err" if $err;
push @diag, " $_" for split /\r?\n/, $out;
}
}
push @diag, "xs_ok called without any aliens, you may want to call alien_ok" unless @aliens || $ENV{TEST_ALIEN_ALIENS_MISSING};
if($ok)
{
my $cb = ExtUtils::CBuilder->new(
config => do {
my %config = %{ $xs->{cbuilder_config} };
my $lddlflags = join(' ', grep !/^-l/, shellwords map { _flags $_, 'libs' } @aliens) . " $Config{lddlflags}";
$config{lddlflags} = defined $config{lddlflags} ? "$lddlflags $config{lddlflags}" : $lddlflags;
\%config;
},
);
my %compile_options = (
source => $c_filename,
%{ $xs->{cbuilder_compile} },
);
if(defined $compile_options{extra_compiler_flags} && ref($compile_options{extra_compiler_flags}) eq '')
{
$compile_options{extra_compiler_flags} = [ shellwords $compile_options{extra_compiler_flags} ];
}
push @{ $compile_options{extra_compiler_flags} }, shellwords map { _flags $_, 'cflags' } @aliens;
my($out, $obj, $err) = capture_merged {
my $obj = eval {
$cb->compile(%compile_options);
};
($obj, $@);
};
$ctx->note("compile $c_filename") if $verbose;
$ctx->note($out) if $verbose;
$ctx->note($err) if $verbose && $err;
if($verbose > 1)
{
$ctx->note(_dump({ compile_options => \%compile_options }));
}
unless($obj)
{
$ok = 0;
push @diag, ' ExtUtils::CBuilder->compile failed';
push @diag, " $err" if $err;
push @diag, " $_" for split /\r?\n/, $out;
}
if($ok)
{
my %link_options = (
objects => [$obj],
module_name => $module,
%{ $xs->{cbuilder_link} },
);
if(defined $link_options{extra_linker_flags} && ref($link_options{extra_linker_flags}) eq '')
{
$link_options{extra_linker_flags} = [ shellwords $link_options{extra_linker_flags} ];
}
unshift @{ $link_options{extra_linker_flags} }, grep /^-l/, shellwords map { _flags $_, 'libs' } @aliens;
my($out, $lib, $err) = capture_merged {
my $lib = eval {
$cb->link(%link_options);
};
($lib, $@);
};
$ctx->note("link $obj") if $verbose;
$ctx->note($out) if $verbose;
$ctx->note($err) if $verbose && $err;
if($verbose > 1)
{
$ctx->note(_dump({ link_options => \%link_options }));
}
if($lib && -f $lib)
{
$ctx->note("created lib $lib") if $xs->{verbose};
}
else
{
$ok = 0;
push @diag, ' ExtUtils::CBuilder->link failed';
push @diag, " $err" if $err;
push @diag, " $_" for split /\r?\n/, $out;
}
if($ok)
{
my @modparts = split(/::/,$module);
my $dl_dlext = $Config{dlext};
my $modfname = $modparts[-1];
my $libpath = path($dir)->child('auto', @modparts, "$modfname.$dl_dlext");
$libpath->parent->mkpath;
move($lib, "$libpath") || die "unable to copy $lib => $libpath $!";
pop @modparts;
my $pmpath = path($dir)->child(@modparts, "$modfname.pm");
$pmpath->parent->mkpath;
open my $fh, '>', "$pmpath";
my($alien_with_xs_load, @rest) = grep { $_->can('xs_load') } @aliens;
if($alien_with_xs_load)
{
{
no strict 'refs';
@{join '::', $module, 'rest'} = @rest;
${join '::', $module, 'alien_with_xs_load'} = $alien_with_xs_load;
}
print $fh '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) . qq{
package $module;
use strict;
use warnings;
our \$VERSION = '0.01';
our \@rest;
our \$alien_with_xs_load;
\$alien_with_xs_load->xs_load('$module', \$VERSION, \@rest);
1;
};
}
else
{
print $fh '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) . qq{
package $module;
use strict;
use warnings;
require XSLoader;
our \$VERSION = '0.01';
XSLoader::load('$module',\$VERSION);
1;
};
}
close $fh;
{
local @INC = @INC;
unshift @INC, "$dir";
## no critic
eval '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) . qq{
use $module;
};
## use critic
}
if(my $error = $@)
{
$ok = 0;
push @diag, ' XSLoader failed';
push @diag, " $error";
}
}
}
}
$ctx->ok($ok, $message);
$ctx->diag($_) for @diag;
$ctx->release;
unless($ok || defined $ENV{TEST_ALIEN_ALWAYS_KEEP})
{
$ctx->note("keeping XS temporary directory $dir due to failure");
$dir->unlink_on_destroy(0);
}
if($cb)
{
$cb = sub {
my $ctx = context();
$ctx->plan(0, 'SKIP', "subtest requires xs success");
$ctx->release;
} unless $ok;
@_ = ("$message subtest", $cb, 1, $module);
goto \&Test2::API::run_subtest;
}
$ok;
}
sub with_subtest (&)
{
my($code) = @_;
# it may be possible to catch a segmentation fault,
# but not with signal handlers apparently. See:
# https://feepingcreature.github.io/handling.html
return $code if $^O eq 'MSWin32';
# try to catch a segmentation fault and bail out
# with a useful diagnostic. prove test to swallow
# the diagnostic on such failures.
sub {
local $SIG{SEGV} = sub {
my $ctx = context();
$ctx->bail("Segmentation fault");
};
$code->(@_);
}
}
sub ffi_ok
{
my $cb;
$cb = pop if defined $_[-1] && ref $_[-1] eq 'CODE';
my($opt, $message) = @_;
$message ||= 'ffi';
my $ok = 1;
my $skip;
my $ffi;
my @diag;
{
my $min = '0.12'; # the first CPAN release
$min = '0.15' if $opt->{ignore_not_found};
$min = '0.18' if $opt->{lang};
$min = '0.99' if defined $opt->{api} && $opt->{api} > 0;
unless(eval { require FFI::Platypus; FFI::Platypus->VERSION($min) })
{
$ok = 0;
$skip = "Test requires FFI::Platypus $min";
}
}
if($ok && $opt->{lang})
{
my $class = "FFI::Platypus::Lang::@{[ $opt->{lang} ]}";
{
my $pm = "$class.pm";
$pm =~ s/::/\//g;
eval { require $pm };
}
if($@)
{
$ok = 0;
$skip = "Test requires FFI::Platypus::Lang::@{[ $opt->{lang} ]}";
}
}
unless(@aliens || $ENV{TEST_ALIEN_ALIENS_MISSING})
{
push @diag, 'ffi_ok called without any aliens, you may want to call alien_ok';
}
if($ok)
{
$ffi = FFI::Platypus->new(
do {
my @args = (
lib => [map { $_->dynamic_libs } @aliens],
ignore_not_found => $opt->{ignore_not_found},
lang => $opt->{lang},
);
push @args, api => $opt->{api} if defined $opt->{api};
@args;
}
);
foreach my $symbol (@{ $opt->{symbols} || [] })
{
unless($ffi->find_symbol($symbol))
{
$ok = 0;
push @diag, " $symbol not found"
}
}
}
my $ctx = context();
if($skip)
{
$ctx->skip($message, $skip);
}
else
{
$ctx->ok($ok, $message);
}
$ctx->diag($_) for @diag;
$ctx->release;
if($cb)
{
$cb = sub {
my $ctx = context();
$ctx->plan(0, 'SKIP', "subtest requires ffi success");
$ctx->release;
} unless $ok;
@_ = ("$message subtest", $cb, 1, $ffi);
goto \&Test2::API::run_subtest;
}
$ok;
}
{
my @ret;
sub _interpolator
{
return @ret if @ret;
require Alien::Build::Interpolate::Default;
my $intr = Alien::Build::Interpolate::Default->new;
require Alien::Build;
my $build = Alien::Build->new;
$build->meta->interpolator($intr);
@ret = ($intr, $build);
}
}
sub helper_ok
{
my($name, $message) = @_;
$message ||= "helper $name exists";
my($intr) = _interpolator;
my $code = $intr->has_helper($name);
my $ok = defined $code;
my $ctx = context();
$ctx->ok($ok, $message);
$ctx->diag("helper_ok called without any aliens, you may want to call alien_ok") unless @aliens || $ENV{TEST_ALIEN_ALIENS_MISSING};
$ctx->release;
$ok;
}
sub plugin_ok
{
my($name, $message) = @_;
my @args;
($name, @args) = @$name if ref $name;
$message ||= "plugin $name";
my($intr, $build) = _interpolator;
my $class = "Alien::Build::Plugin::$name";
my $pm = "$class.pm";
$pm =~ s/::/\//g;
my $ctx = context();
my $plugin = eval {
require $pm unless $class->can('new');
$class->new(@args);
};
if(my $error = $@)
{
$ctx->ok(0, $message, ['unable to create $name plugin', $error]);
$ctx->release;
return 0;
}
eval {
$plugin->init($build->meta);
};
if($^O eq 'MSWin32' && ($plugin->isa('Alien::Build::Plugin::Build::MSYS') || $plugin->isa('Alien::Build::Plugin::Build::Autoconf')))
{
require Alien::MSYS;
unshift @PATH, Alien::MSYS::msys_path();
}
if(my $error = $@)
{
$ctx->ok(0, $message, ['unable to initiate $name plugin', $error]);
$ctx->release;
return 0;
}
else
{
$ctx->ok(1, $message);
$ctx->release;
return 1;
}
}
sub interpolate_template_is
{
my($template, $pattern, $message) = @_;
$message ||= "template matches";
my($intr) = _interpolator;
my $value = eval { $intr->interpolate($template) };
my $error = $@;
my @diag;
my $ok;
if($error)
{
$ok = 0;
push @diag, "error in evaluation:";
push @diag, " $error";
}
elsif(ref($pattern) eq 'Regexp')
{
$ok = $value =~ $pattern;
push @diag, "value '$value' does not match $pattern'" unless $ok;
}
else
{
$ok = $value eq "$pattern";
push @diag, "value '$value' does not equal '$pattern'" unless $ok;
}
my $ctx = context();
$ctx->ok($ok, $message, [@diag]);
$ctx->diag('interpolate_template_is called without any aliens, you may want to call alien_ok') unless @aliens || $ENV{TEST_ALIEN_ALIENS_MISSING};
$ctx->release;
$ok;
}
sub interpolate_run_ok
{
my($template, $message) = @_;
my(@template) = ref $template ? @$template : ($template);
my($intr) = _interpolator;
my $ok = 1;
my @diag;
my @command;
foreach my $template (@template)
{
my $command = eval { $intr->interpolate($template) };
if(my $error = $@)
{
$ok = 0;
push @diag, "error in evaluation:";
push @diag, " $error";
}
else
{
push @command, $command;
}
}
my $ctx = context();
if($ok)
{
my $command = ref $template ? \@command : $command[0];
$ok = run_ok($command, $message);
}
else
{
$message ||= "run @template";
$ctx->ok($ok, $message, [@diag]);
$ctx->diag('interpolate_run_ok called without any aliens, you may want to call alien_ok') unless @aliens || $ENV{TEST_ALIEN_ALIENS_MISSING};
}
$ctx->release;
$ok;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test::Alien - Testing tools for Alien modules
=head1 VERSION
version 2.80
=head1 SYNOPSIS
Test commands that come with your Alien:
use Test2::V0;
use Test::Alien;
use Alien::patch;
alien_ok 'Alien::patch';
run_ok([ 'patch', '--version' ])
->success
# we only accept the version written
# by Larry ...
->out_like(qr{Larry Wall});
done_testing;
Test that your library works with C:
use Test2::V0;
use Test::Alien;
use Alien::Editline;
alien_ok 'Alien::Editline';
my $xs = do { local $/; };
xs_ok $xs, with_subtest {
my($module) = @_;
ok $module->version;
};
done_testing;
__DATA__
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include
const char *
version(const char *class)
{
return rl_library_version;
}
MODULE = TA_MODULE PACKAGE = TA_MODULE
const char *version(class);
const char *class;
Test that your library works with L:
use Test2::V0;
use Test::Alien;
use Alien::LibYAML;
alien_ok 'Alien::LibYAML';
ffi_ok { symbols => ['yaml_get_version'] }, with_subtest {
my($ffi) = @_;
my $get_version = $ffi->function(yaml_get_version => ['int*','int*','int*'] => 'void');
$get_version->call(\my $major, \my $minor, \my $patch);
like $major, qr{[0-9]+};
like $minor, qr{[0-9]+};
like $patch, qr{[0-9]+};
};
done_testing;
=head1 DESCRIPTION
This module provides tools for testing L modules. It has hooks
to work easily with L based modules, but can also be used
via the synthetic interface to test non L based L
modules. It has very modest prerequisites.
Prior to this module the best way to test a L module was via L.
The main downside to that module is that it is heavily influenced by and uses
L, which is a tool for checking at install time various things
about your compiler. It was also written before L became as stable as it
is today. In particular, L does its testing by creating an executable
and running it. Unfortunately Perl uses extensions by creating dynamic libraries
and linking them into the Perl process, which is different in subtle and error prone
ways. This module attempts to test the libraries in the way that they will actually
be used, via either C or L. It also provides a mechanism for
testing binaries that are provided by the various L modules (for example
L and L).
L modules can actually be useable without a compiler, or without L
(for example, if the library is provided by the system, and you are using L,
or if you are building from source and you are using C), so tests with missing
prerequisites are automatically skipped. For example, L will automatically skip
itself if a compiler is not found, and L will automatically skip itself
if L is not installed.
=head1 FUNCTIONS
=head2 alien_ok
alien_ok $alien, $message;
alien_ok $alien;
Load the given L instance or class. Checks that the instance or class conforms to the same
interface as L. Will be used by subsequent tests. The C<$alien> module only needs to
provide these methods in order to conform to the L interface:
=over 4
=item cflags
String containing the compiler flags
=item libs
String containing the linker and library flags
=item dynamic_libs
List of dynamic libraries. Returns empty list if the L module does not provide this.
=item bin_dir
Directory containing tool binaries. Returns empty list if the L module does not provide
this.
=back
If your L module does not conform to this interface then you can create a synthetic L
module using the L function.
=head2 synthetic
my $alien = synthetic \%config;
Create a synthetic L module which can be passed into L. C<\%config>
can contain these keys (all of which are optional):
=over 4
=item cflags
String containing the compiler flags.
=item cflags_static
String containing the static compiler flags (optional).
=item libs
String containing the linker and library flags.
=item libs_static
String containing the static linker flags (optional).
=item dynamic_libs
List reference containing the dynamic libraries.
=item bin_dir
Tool binary directory.
=item runtime_prop
Runtime properties.
=back
See L for more details.
=head2 run_ok
my $run = run_ok $command;
my $run = run_ok $command, $message;
Runs the given command, falling back on any C methods provided by L modules
specified with L.
C<$command> can be either a string or an array reference.
Only fails if the command cannot be found, or if it is killed by a signal! Returns a L
object, which you can use to test the exit status, output and standard error.
Always returns an instance of L, even if the command could not be found.
=head2 xs_ok
xs_ok $xs;
xs_ok $xs, $message;
Compiles, links the given C code and attaches to Perl.
If you use the special module name C in your C
code, it will be replaced by an automatically generated
package name. This can be useful if you want to pass the same
C code to multiple calls to C without subsequent
calls replacing previous ones.
C<$xs> may be either a string containing the C code,
or a hash reference with these keys:
=over 4
=item xs
The XS code. This is the only required element.
=item pxs
Extra L arguments passed in as a hash reference.
=item cbuilder_check
The compile check that should be done prior to attempting to build.
Should be one of C or C. Defaults
to C.
=item cbuilder_config
Hash to override values normally provided by C.
=item cbuilder_compile
Extra The L arguments passed in as a hash reference.
=item cbuilder_link
Extra The L arguments passed in as a hash reference.
=item verbose
Spew copious debug information via test note.
=back
You can use the C keyword to conditionally
run a subtest if the C call succeeds. If C
does not work, then the subtest will automatically be
skipped. Example:
xs_ok $xs, with_subtest {
# skipped if $xs fails for some reason
my($module) = @_;
is $module->foo, 1;
};
The module name detected during the XS parsing phase will
be passed in to the subtest. This is helpful when you are
using a generated module name.
If you need to test XS C++ interfaces, see L.
Caveats: C uses L, which may call C
under certain error conditions. While this is not really good
thing to happen in the middle of a test, it usually indicates
a real failure condition, and it should return a failure condition
so the test should still fail overall.
[version 2.53]
As of version 2.53, C will only remove temporary generated files
if the test is successful by default. You can force either always
or never removing the temporary generated files using the
C environment variable (see L below).
=head2 ffi_ok
ffi_ok;
ffi_ok \%opt;
ffi_ok \%opt, $message;
Test that L works.
C<\%opt> is a hash reference with these keys (all optional):
=over 4
=item symbols
List references of symbols that must be found for the test to succeed.
=item ignore_not_found
Ignores symbols that aren't found. This affects functions accessed via
L and L methods, and does
not influence the C key above.
=item lang
Set the language. Used primarily for language specific native types.
=item api
Set the API. C requires FFI::Platypus 0.99 or later. This
option was added with Test::Alien version 1.90, so your use line should
include this version as a safeguard to make sure it works:
use Test::Alien 1.90;
...
ffi_ok ...;
=back
As with L above, you can use the C keyword to specify
a subtest to be run if C succeeds (it will skip otherwise). The
L instance is passed into the subtest as the first argument.
For example:
ffi_ok with_subtest {
my($ffi) = @_;
is $ffi->function(foo => [] => 'void')->call, 42;
};
=head2 helper_ok
helper_ok $name;
helper_ok $name, $message;
Tests that the given helper has been defined.
=head2 plugin_ok
[version 2.52]
plugin_ok $plugin_name, $message;
plugin_ok [$plugin_name, @args], $message;
This applies an L to the interpolator used by L, L
and L so that you can test with any helpers that plugin provides. Useful,
for example for getting C<%{configure}> from L.
=head2 interpolate_template_is
interpolate_template_is $template, $string;
interpolate_template_is $template, $string, $message;
interpolate_template_is $template, $regex;
interpolate_template_is $template, $regex, $message;
Tests that the given template when evaluated with the appropriate helpers will match
either the given string or regular expression.
=head2 interpolate_run_ok
[version 2.52]
my $run = interpolate_run_ok $command;
my $run = interpolate_run_ok $command, $message;
This is the same as L except it runs the command through the interpolator first.
=head1 ENVIRONMENT
=over 4
=item C
If this is defined then it will override the built in logic that decides if
the temporary files generated by L should be kept when the test file
terminates. If set to true the generated files will always be kept. If
set to false, then they will always be removed.
=item C
By default, this module will warn you if some tools are used without first
invoking L. This is usually a mistake, but if you really do
want to use one of these tools with no aliens loaded, you can set this
environment variable to false.
=back
=head1 SEE ALSO
=over 4
=item L
=item L
=item L
=item L
=item L
=item L
=item L
=item L
=item L
=item L
=back
=head1 AUTHOR
Author: Graham Ollis Eplicease@cpan.orgE
Contributors:
Diab Jerius (DJERIUS)
Roy Storey (KIWIROY)
Ilya Pavlov
David Mertens (run4flat)
Mark Nunberg (mordy, mnunberg)
Christian Walde (Mithaldu)
Brian Wightman (MidLifeXis)
Zaki Mughal (zmughal)
mohawk (mohawk2, ETJ)
Vikas N Kumar (vikasnkumar)
Flavio Poletti (polettix)
Salvador Fandiño (salva)
Gianni Ceccarelli (dakkar)
Pavel Shaydo (zwon, trinitum)
Kang-min Liu (劉康民, gugod)
Nicholas Shipp (nshp)
Juan Julián Merelo Guervós (JJ)
Joel Berger (JBERGER)
Petr Písař (ppisar)
Lance Wicks (LANCEW)
Ahmad Fatoum (a3f, ATHREEF)
José Joaquín Atria (JJATRIA)
Duke Leto (LETO)
Shoichi Kaji (SKAJI)
Shawn Laffan (SLAFFAN)
Paul Evans (leonerd, PEVANS)
Håkon Hægland (hakonhagland, HAKONH)
nick nauwelaerts (INPHOBIA)
Florian Weimer
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2011-2022 by Graham Ollis.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
PK ! vk Alien/CanCompile.pmnu 6$ package Test::Alien::CanCompile;
use strict;
use warnings;
use 5.008004;
use Test2::API qw( context );
# ABSTRACT: Skip a test file unless a C compiler is available
our $VERSION = '2.80'; # VERSION
sub skip
{
require ExtUtils::CBuilder;
ExtUtils::CBuilder->new->have_compiler ? undef : 'This test requires a compiler.';
}
sub import
{
my $skip = __PACKAGE__->skip;
return unless defined $skip;
my $ctx = context();
$ctx->plan(0, SKIP => $skip);
$ctx->release;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test::Alien::CanCompile - Skip a test file unless a C compiler is available
=head1 VERSION
version 2.80
=head1 SYNOPSIS
use Test::Alien::CanCompile;
=head1 DESCRIPTION
This is just a L plugin that requires that a compiler
be available. Otherwise the test will be skipped.
=head1 SEE ALSO
=over 4
=item L
=back
=head1 AUTHOR
Author: Graham Ollis Eplicease@cpan.orgE
Contributors:
Diab Jerius (DJERIUS)
Roy Storey (KIWIROY)
Ilya Pavlov
David Mertens (run4flat)
Mark Nunberg (mordy, mnunberg)
Christian Walde (Mithaldu)
Brian Wightman (MidLifeXis)
Zaki Mughal (zmughal)
mohawk (mohawk2, ETJ)
Vikas N Kumar (vikasnkumar)
Flavio Poletti (polettix)
Salvador Fandiño (salva)
Gianni Ceccarelli (dakkar)
Pavel Shaydo (zwon, trinitum)
Kang-min Liu (劉康民, gugod)
Nicholas Shipp (nshp)
Juan Julián Merelo Guervós (JJ)
Joel Berger (JBERGER)
Petr Písař (ppisar)
Lance Wicks (LANCEW)
Ahmad Fatoum (a3f, ATHREEF)
José Joaquín Atria (JJATRIA)
Duke Leto (LETO)
Shoichi Kaji (SKAJI)
Shawn Laffan (SLAFFAN)
Paul Evans (leonerd, PEVANS)
Håkon Hægland (hakonhagland, HAKONH)
nick nauwelaerts (INPHOBIA)
Florian Weimer
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2011-2022 by Graham Ollis.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
PK ! lp p Alien/Synthetic.pmnu 6$ package Test::Alien::Synthetic;
use strict;
use warnings;
use 5.008004;
use Test2::API qw( context );
# ABSTRACT: A mock alien object for testing
our $VERSION = '2.80'; # VERSION
sub _def ($) { my($val) = @_; defined $val ? $val : '' }
sub cflags { _def shift->{cflags} }
sub libs { _def shift->{libs} }
sub dynamic_libs { @{ shift->{dynamic_libs} || [] } }
sub runtime_prop
{
my($self) = @_;
defined $self->{runtime_prop}
? $self->{runtime_prop}
: {};
}
sub cflags_static
{
my($self) = @_;
defined $self->{cflags_static}
? $self->{cflags_static}
: $self->cflags;
}
sub libs_static
{
my($self) = @_;
defined $self->{libs_static}
? $self->{libs_static}
: $self->libs;
}
sub bin_dir
{
my $dir = shift->{bin_dir};
defined $dir && -d $dir ? ($dir) : ();
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test::Alien::Synthetic - A mock alien object for testing
=head1 VERSION
version 2.80
=head1 SYNOPSIS
use Test2::V0;
use Test::Alien;
my $alien = synthetic {
cflags => '-I/foo/bar/include',
libs => '-L/foo/bar/lib -lbaz',
};
alien_ok $alien;
done_testing;
=head1 DESCRIPTION
This class is used to model a synthetic L
class that implements the minimum L
interface needed by L.
It can be useful if you have a non-L
based L distribution that you need to test.
B: The name of this class may move in the
future, so do not refer to this class name directly.
Instead create instances of this class using the
L function.
=head1 ATTRIBUTES
=head2 cflags
String containing the compiler flags
=head2 cflags_static
String containing the static compiler flags
=head2 libs
String containing the linker and library flags
=head2 libs_static
String containing the static linker and library flags
=head2 dynamic_libs
List reference containing the dynamic libraries.
=head2 bin_dir
Tool binary directory.
=head2 runtime_prop
Runtime properties.
=head1 EXAMPLE
Here is a complete example using L which is a non-L
based L distribution.
use strict;
use warnings;
use Test2::V0;
use Test::Alien;
use Alien::Libarchive;
my $real = Alien::Libarchive->new;
my $alien = synthetic {
cflags => scalar $real->cflags,
libs => scalar $real->libs,
dynamic_libs => [$real->dlls],
};
alien_ok $alien;
xs_ok do { local $/; }, with_subtest {
my($module) = @_;
my $ptr = $module->archive_read_new;
like $ptr, qr{^[0-9]+$};
$module->archive_read_free($ptr);
};
ffi_ok { symbols => [qw( archive_read_new )] }, with_subtest {
my($ffi) = @_;
my $new = $ffi->function(archive_read_new => [] => 'opaque');
my $free = $ffi->function(archive_read_close => ['opaque'] => 'void');
my $ptr = $new->();
like $ptr, qr{^[0-9]+$};
$free->($ptr);
};
done_testing;
__DATA__
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include
MODULE = TA_MODULE PACKAGE = TA_MODULE
void *archive_read_new(class);
const char *class;
CODE:
RETVAL = (void*) archive_read_new();
OUTPUT:
RETVAL
void archive_read_free(class, ptr);
const char *class;
void *ptr;
CODE:
archive_read_free(ptr);
=head1 SEE ALSO
=over 4
=item L
=back
=head1 AUTHOR
Author: Graham Ollis Eplicease@cpan.orgE
Contributors:
Diab Jerius (DJERIUS)
Roy Storey (KIWIROY)
Ilya Pavlov
David Mertens (run4flat)
Mark Nunberg (mordy, mnunberg)
Christian Walde (Mithaldu)
Brian Wightman (MidLifeXis)
Zaki Mughal (zmughal)
mohawk (mohawk2, ETJ)
Vikas N Kumar (vikasnkumar)
Flavio Poletti (polettix)
Salvador Fandiño (salva)
Gianni Ceccarelli (dakkar)
Pavel Shaydo (zwon, trinitum)
Kang-min Liu (劉康民, gugod)
Nicholas Shipp (nshp)
Juan Julián Merelo Guervós (JJ)
Joel Berger (JBERGER)
Petr Písař (ppisar)
Lance Wicks (LANCEW)
Ahmad Fatoum (a3f, ATHREEF)
José Joaquín Atria (JJATRIA)
Duke Leto (LETO)
Shoichi Kaji (SKAJI)
Shawn Laffan (SLAFFAN)
Paul Evans (leonerd, PEVANS)
Håkon Hægland (hakonhagland, HAKONH)
nick nauwelaerts (INPHOBIA)
Florian Weimer
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2011-2022 by Graham Ollis.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
PK ! 0sd
Alien/Diag.pmnu 6$ package Test::Alien::Diag;
use strict;
use warnings;
use 5.008004;
use Test2::API qw( context );
use Exporter qw( import );
our @EXPORT = qw( alien_diag );
our @EXPORT_OK = @EXPORT;
# ABSTRACT: Print out standard diagnostic for Aliens in the test step.
our $VERSION = '2.80'; # VERSION
my @default_scalar_properties = qw(
cflags cflags_static libs libs_static version install_type
);
my @default_list_properties = qw(
dynamic_libs bin_dir
);
sub alien_diag ($@)
{
my $ctx = context();
my %options = defined $_[-1] && ref($_[-1]) eq 'HASH' ? %{ pop @_ } : ();
my @extra_properties = @{ delete $options{properties} || [] };
my @extra_list_properties = @{ delete $options{list_properties} || [] };
my $max = 0;
foreach my $alien (@_)
{
foreach my $name (@default_scalar_properties, @default_list_properties, @extra_properties, @extra_list_properties)
{
if(eval { $alien->can($name) })
{
my $str = "$alien->$name";
if(length($str) > $max)
{
$max = length($str);
}
}
}
}
$ctx->diag('');
if(%options)
{
my @extra = sort keys %options;
$ctx->diag("warning: unknown option@{[ @extra > 1 ? 's' : '' ]} for alien_diag: @extra");
$ctx->diag("(you should check for typos or maybe upgrade to a newer version of Alien::Build)");
}
foreach my $alien (@_) {
$ctx->diag('') for 1..2;
my $found = 0;
foreach my $name (sort(@default_scalar_properties, @extra_properties))
{
if(eval { $alien->can($name) })
{
$found++;
my $value = $alien->$name;
$value = '[undef]' unless defined $value;
$ctx->diag(sprintf "%-${max}s = %s", "$alien->$name", $value);
}
}
foreach my $name (sort(@default_list_properties, @extra_list_properties))
{
if(eval { $alien->can($name) })
{
$found++;
my @list = eval { $alien->$name };
next if $@;
$ctx->diag(sprintf "%-${max}s = %s", "$alien->$name", $_) for @list;
}
}
$ctx->diag("no diagnostics found for $alien") unless $found;
}
$ctx->diag('') for 1..2;
$ctx->release;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test::Alien::Diag - Print out standard diagnostic for Aliens in the test step.
=head1 VERSION
version 2.80
=head1 SYNOPSIS
use Test2::V0;
use Test::Alien::Diag qw( alien_diag );
=head1 DESCRIPTION
This module provides an C method that prints out diagnostics useful for
cpantesters and other bug reports that gives a quick summary of the important settings
like C and C.
=head1 FUNCTIONS
=head2 alien_diag
alien_diag @aliens;
prints out diagnostics for each given alien. Each alien must be the class
name of an alien.
[version 2.68]
alien_diag @aliens, \%options;
Starting with L 2.68, you can provide an option hash to adjust the
behavior of C. Valid options are:
=over 4
=item properties
Additional properties to display in the diagnostic. Useful when you have an L
with custom properties defined in the subclass.
=item list_properties
Additional properties that are returned as a list to display in the diagnostic. Useful
when you have an L with customer properties that return a list.
=back
=head1 AUTHOR
Author: Graham Ollis Eplicease@cpan.orgE
Contributors:
Diab Jerius (DJERIUS)
Roy Storey (KIWIROY)
Ilya Pavlov
David Mertens (run4flat)
Mark Nunberg (mordy, mnunberg)
Christian Walde (Mithaldu)
Brian Wightman (MidLifeXis)
Zaki Mughal (zmughal)
mohawk (mohawk2, ETJ)
Vikas N Kumar (vikasnkumar)
Flavio Poletti (polettix)
Salvador Fandiño (salva)
Gianni Ceccarelli (dakkar)
Pavel Shaydo (zwon, trinitum)
Kang-min Liu (劉康民, gugod)
Nicholas Shipp (nshp)
Juan Julián Merelo Guervós (JJ)
Joel Berger (JBERGER)
Petr Písař (ppisar)
Lance Wicks (LANCEW)
Ahmad Fatoum (a3f, ATHREEF)
José Joaquín Atria (JJATRIA)
Duke Leto (LETO)
Shoichi Kaji (SKAJI)
Shawn Laffan (SLAFFAN)
Paul Evans (leonerd, PEVANS)
Håkon Hægland (hakonhagland, HAKONH)
nick nauwelaerts (INPHOBIA)
Florian Weimer
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2011-2022 by Graham Ollis.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
PK ! (c>E E Alien/Build.pmnu 6$ package Test::Alien::Build;
use strict;
use warnings;
use 5.008004;
use Exporter qw( import );
use Path::Tiny qw( path );
use Carp qw( croak );
use Test2::API qw( context run_subtest );
use Capture::Tiny qw( capture_merged );
use Alien::Build::Util qw( _mirror );
use List::Util 1.33 qw( any );
use Alien::Build::Temp;
our @EXPORT = qw(
alienfile
alienfile_ok
alienfile_skip_if_missing_prereqs
alien_download_ok
alien_extract_ok
alien_build_ok
alien_build_clean
alien_clean_install
alien_install_type_is
alien_checkpoint_ok
alien_resume_ok
alien_subtest
alien_rc
);
# ABSTRACT: Tools for testing Alien::Build + alienfile
our $VERSION = '2.80'; # VERSION
my $build;
my $build_alienfile;
my $build_root;
my $build_targ;
sub alienfile::targ
{
$build_targ;
}
sub alienfile
{
my($package, $filename, $line) = caller;
($package, $filename, $line) = caller(2) if $package eq __PACKAGE__;
$filename = path($filename)->absolute;
my %args = @_ == 0 ? (filename => 'alienfile') : @_ % 2 ? ( source => do { '# line '. $line . ' "' . path($filename)->absolute . qq("\n) . $_[0] }) : @_;
require alienfile;
push @alienfile::EXPORT, 'targ' unless any { /^targ$/ } @alienfile::EXPORT;
my $temp = Alien::Build::Temp->newdir;
my $get_temp_root = do{
my $root; # may be undef;
sub {
$root ||= Path::Tiny->new($temp);
if(@_)
{
my $path = $root->child(@_);
$path->mkpath;
$path;
}
else
{
return $root;
}
};
};
if($args{source})
{
my $file = $get_temp_root->()->child('alienfile');
$file->spew_utf8($args{source});
$args{filename} = $file->stringify;
}
else
{
unless(defined $args{filename})
{
croak "You must specify at least one of filename or source";
}
$args{filename} = path($args{filename})->absolute->stringify;
}
$args{stage} ||= $get_temp_root->('stage')->stringify;
$args{prefix} ||= $get_temp_root->('prefix')->stringify;
$args{root} ||= $get_temp_root->('root')->stringify;
require Alien::Build;
_alienfile_clear();
my $out = capture_merged {
$build_targ = $args{targ};
$build = Alien::Build->load($args{filename}, root => $args{root});
$build->set_stage($args{stage});
$build->set_prefix($args{prefix});
};
my $ctx = context();
$ctx->note($out) if $out;
$ctx->release;
$build_alienfile = $args{filename};
$build_root = $temp;
$build
}
sub _alienfile_clear
{
eval { defined $build_root && -d $build_root && path($build_root)->remove_tree };
undef $build;
undef $build_alienfile;
undef $build_root;
undef $build_targ;
}
sub alienfile_ok
{
my $build;
my $name;
my $error;
if(@_ == 1 && ! defined $_[0])
{
$build = $_[0];
$error = 'no alienfile given';
$name = 'alienfile compiled';
}
elsif(@_ == 1 && eval { $_[0]->isa('Alien::Build') })
{
$build = $_[0];
$name = 'alienfile compiled';
}
else
{
$build = eval { alienfile(@_) };
$error = $@;
$name = 'alienfile compiles';
}
my $ok = !! $build;
my $ctx = context();
$ctx->ok($ok, $name);
$ctx->diag("error: $error") if $error;
$ctx->release;
$build;
}
sub alienfile_skip_if_missing_prereqs
{
my($phase) = @_;
if($build)
{
eval { $build->load_requires('configure', 1) };
if(my $error = $@)
{
my $reason = "Missing configure prereq";
if($error =~ /Required (.*) (.*),/)
{
$reason .= ": $1 $2";
}
my $ctx = context();
$ctx->plan(0, SKIP => $reason);
$ctx->release;
return;
}
$phase ||= $build->install_type;
eval { $build->load_requires($phase, 1) };
if(my $error = $@)
{
my $reason = "Missing $phase prereq";
if($error =~ /Required (.*) (.*),/)
{
$reason .= ": $1 $2";
}
my $ctx = context();
$ctx->plan(0, SKIP => $reason);
$ctx->release;
return;
}
}
}
sub alien_install_type_is
{
my($type, $name) = @_;
croak "invalid install type" unless defined $type && $type =~ /^(system|share)$/;
$name ||= "alien install type is $type";
my $ok = 0;
my @diag;
if($build)
{
my($out, $actual) = capture_merged {
$build->load_requires('configure');
$build->install_type;
};
if($type eq $actual)
{
$ok = 1;
}
else
{
push @diag, "expected install type of $type, but got $actual";
}
}
else
{
push @diag, 'no alienfile'
}
my $ctx = context();
$ctx->ok($ok, $name);
$ctx->diag($_) for @diag;
$ctx->release;
$ok;
}
sub alien_download_ok
{
my($name) = @_;
$name ||= 'alien download';
my $ok;
my $file;
my @diag;
my @note;
if($build)
{
my($out, $error) = capture_merged {
eval {
$build->load_requires('configure');
$build->load_requires($build->install_type);
$build->download;
};
$@;
};
if($error)
{
$ok = 0;
push @diag, $out if defined $out;
push @diag, "extract threw exception: $error";
}
else
{
$file = $build->install_prop->{download};
if(-d $file || -f $file)
{
$ok = 1;
push @note, $out if defined $out;
}
else
{
$ok = 0;
push @diag, $out if defined $out;
push @diag, 'no file or directory';
}
}
}
else
{
$ok = 0;
push @diag, 'no alienfile';
}
my $ctx = context();
$ctx->ok($ok, $name);
$ctx->note($_) for @note;
$ctx->diag($_) for @diag;
$ctx->release;
$file;
}
sub alien_extract_ok
{
my($archive, $name) = @_;
$name ||= $archive ? "alien extraction of $archive" : 'alien extraction';
my $ok;
my $dir;
my @diag;
my @note;
if($build)
{
my($out, $error);
($out, $dir, $error) = capture_merged {
my $dir = eval {
$build->load_requires('configure');
$build->load_requires($build->install_type);
$build->download;
$build->extract($archive);
};
($dir, $@);
};
if($error)
{
$ok = 0;
push @diag, $out if defined $out;
push @diag, "extract threw exception: $error";
}
else
{
if(-d $dir)
{
$ok = 1;
push @note, $out if defined $out;
}
else
{
$ok = 0;
push @diag, $out if defined $out;
push @diag, 'no directory';
}
}
}
else
{
$ok = 0;
push @diag, 'no alienfile';
}
my $ctx = context();
$ctx->ok($ok, $name);
$ctx->note($_) for @note;
$ctx->diag($_) for @diag;
$ctx->release;
$dir;
}
my $count = 1;
sub alien_build_ok
{
my $opt = defined $_[0] && ref($_[0]) eq 'HASH'
? shift : { class => 'Alien::Base' };
my($name) = @_;
$name ||= 'alien builds okay';
my $ok;
my @diag;
my @note;
my $alien;
if($build)
{
my($out,$error) = capture_merged {
eval {
$build->load_requires('configure');
$build->load_requires($build->install_type);
$build->download;
$build->build;
};
$@;
};
if($error)
{
$ok = 0;
push @diag, $out if defined $out;
push @diag, "build threw exception: $error";
}
else
{
$ok = 1;
push @note, $out if defined $out;
require Alien::Base;
my $prefix = $build->runtime_prop->{prefix};
my $stage = $build->install_prop->{stage};
my %prop = %{ $build->runtime_prop };
$prop{distdir} = $prefix;
_mirror $stage, $prefix;
my $dist_dir = sub {
$prefix;
};
my $runtime_prop = sub {
\%prop;
};
$alien = sprintf 'Test::Alien::Build::Faux%04d', $count++;
{
no strict 'refs';
@{ "${alien}::ISA" } = $opt->{class};
*{ "${alien}::dist_dir" } = $dist_dir;
*{ "${alien}::runtime_prop" } = $runtime_prop;
}
}
}
else
{
$ok = 0;
push @diag, 'no alienfile';
}
my $ctx = context();
$ctx->ok($ok, $name);
$ctx->diag($_) for @diag;
$ctx->note($_) for @note;
$ctx->release;
$alien;
}
sub alien_build_clean
{
my $ctx = context();
if($build_root)
{
foreach my $child (path($build_root)->children)
{
next if $child->basename eq 'prefix';
$ctx->note("clean: rm: $child");
$child->remove_tree;
}
}
else
{
$ctx->note("no build to clean");
}
$ctx->release;
}
sub alien_clean_install
{
my($name) = @_;
$name ||= "run clean_install";
my $ok;
my @diag;
my @note;
if($build)
{
my($out,$error) = capture_merged {
eval {
$build->clean_install;
};
$@;
};
if($error)
{
$ok = 0;
push @diag, $out if defined $out && $out ne '';
push @diag, "build threw exception: $error";
}
else
{
$ok = 1;
push @note, $out if defined $out && $out ne '';
}
}
else
{
$ok = 0;
push @diag, 'no alienfile';
}
my $ctx = context();
$ctx->ok($ok, $name);
$ctx->diag($_) for @diag;
$ctx->note($_) for @note;
$ctx->release;
}
sub alien_checkpoint_ok
{
my($name) = @_;
$name ||= "alien checkpoint ok";
my $ok;
my @diag;
if($build)
{
eval { $build->checkpoint };
if($@)
{
push @diag, "error in checkpoint: $@";
$ok = 0;
}
else
{
$ok = 1;
}
undef $build;
}
else
{
push @diag, "no build to checkpoint";
$ok = 0;
}
my $ctx = context();
$ctx->ok($ok, $name);
$ctx->diag($_) for @diag;
$ctx->release;
$ok;
}
sub alien_resume_ok
{
my($name) = @_;
$name ||= "alien resume ok";
my $ok;
my @diag;
if($build_alienfile && $build_root && !defined $build)
{
$build = eval { Alien::Build->resume($build_alienfile, "$build_root/root") };
if($@)
{
push @diag, "error in resume: $@";
$ok = 0;
}
else
{
$ok = 1;
}
}
else
{
if($build)
{
push @diag, "build has not been checkpointed";
}
else
{
push @diag, "no build to resume";
}
$ok = 0;
}
my $ctx = context();
$ctx->ok($ok, $name);
$ctx->diag($_) for @diag;
$ctx->release;
($ok && $build) || $ok;
}
my $alien_rc_root;
sub alien_rc
{
my($code) = @_;
croak "passed in undef rc" unless defined $code;
croak "looks like you have already defined a rc.pl file" if $ENV{ALIEN_BUILD_RC} ne '-';
my(undef, $filename, $line) = caller;
my $code2 = "use strict; use warnings;\n" .
'# line ' . $line . ' "' . path($filename)->absolute . "\n$code";
$alien_rc_root ||= Alien::Build::Temp->newdir;
my $rc = path($alien_rc_root)->child('rc.pl');
$rc->spew_utf8($code2);
$ENV{ALIEN_BUILD_RC} = "$rc";
return 1;
}
sub alien_subtest
{
my($name, $code, @args) = @_;
_alienfile_clear;
my $ctx = context();
my $pass = run_subtest($name, $code, { buffered => 1 }, @args);
$ctx->release;
_alienfile_clear;
$pass;
}
delete $ENV{$_} for qw( ALIEN_BUILD_LOG ALIEN_BUILD_PRELOAD ALIEN_BUILD_POSTLOAD ALIEN_INSTALL_TYPE PKG_CONFIG_PATH ALIEN_BUILD_PKG_CONFIG );
$ENV{ALIEN_BUILD_RC} = '-';
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test::Alien::Build - Tools for testing Alien::Build + alienfile
=head1 VERSION
version 2.80
=head1 SYNOPSIS
use Test2::V0;
use Test::Alien::Build;
# returns an instance of Alien::Build.
my $build = alienfile_ok q{
use alienfile;
plugin 'My::Plugin' => (
foo => 1,
bar => 'string',
...
);
};
alien_build_ok 'builds okay.';
done_testing;
=head1 DESCRIPTION
This module provides some tools for testing L and L. Outside of L
core development, It is probably most useful for L developers.
This module also unsets a number of L specific environment variables, in order to make tests
reproducible even when overrides are set in different environments. So if you want to test those variables in
various states you should explicitly set them in your test script. These variables are unset if they defined:
C C C.
=head1 FUNCTIONS
=head2 alienfile
my $build = alienfile;
my $build = alienfile q{ use alienfile ... };
my $build = alienfile filename => 'alienfile';
Create a Alien::Build instance from the given L. The first two forms are abbreviations.
my $build = alienfile;
# is the same as
my $build = alienfile filename => 'alienfile';
and
my $build = alienfile q{ use alienfile ... };
# is the same as
my $build = alienfile source => q{ use alienfile ... };
Except for the second abbreviated form sets the line number before feeding the source into L
so that you will get diagnostics with the correct line numbers.
=over 4
=item source
The source for the alienfile as a string. You must specify one of C or C.
=item filename
The filename for the alienfile. You must specify one of C or C.
=item root
The build root.
=item stage
The staging area for the build.
=item prefix
The install prefix for the build.
=back
=head2 alienfile_ok
my $build = alienfile_ok;
my $build = alienfile_ok q{ use alienfile ... };
my $build = alienfile_ok filename => 'alienfile';
my $build = alienfile_ok $build;
Same as C above, except that it runs as a test, and will not throw an exception
on failure (it will return undef instead).
[version 1.49]
As of version 1.49 you can also pass in an already formed instance of L. This
allows you to do something like this:
subtest 'a subtest' => sub {
my $build = alienfile q{ use alienfile; ... };
alienfile_skip_if_missing_prereqs; # skip if alienfile prereqs are missing
alienfile_ok $build; # delayed pass/fail for the compile of alienfile
};
=head2 alienfile_skip_if_missing_prereqs
alienfile_skip_if_missing_prereqs;
alienfile_skip_if_missing_prereqs $phase;
Skips the test or subtest if the prereqs for the alienfile are missing.
If C<$phase> is not given, then either C or C will be
detected.
=head2 alien_install_type_is
alien_install_type_is $type;
alien_install_type_is $type, $name;
Simple test to see if the install type is what you expect.
C<$type> should be one of C or C.
=head2 alien_download_ok
my $file = alien_download_ok;
my $file = alien_download_ok $name;
Makes a download attempt and test that a file or directory results. Returns
the file or directory if successful. Returns C otherwise.
=head2 alien_extract_ok
my $dir = alien_extract_ok;
my $dir = alien_extract_ok $archive;
my $dir = alien_extract_ok $archive, $name;
my $dir = alien_extract_ok undef, $name;
Makes an extraction attempt and test that a directory results. Returns
the directory if successful. Returns C otherwise.
=head2 alien_build_ok
my $alien = alien_build_ok;
my $alien = alien_build_ok $name;
my $alien = alien_build_ok { class => $class };
my $alien = alien_build_ok { class => $class }, $name;
Runs the download and build stages. Passes if the build succeeds. Returns an instance
of L which can be passed into C from L. Returns
C if the test fails.
Options
=over 4
=item class
The base class to use for your alien. This is L by default. Should
be a subclass of L, or at least adhere to its API.
=back
=head2 alien_build_clean
alien_build_clean;
Removes all files with the current build, except for the runtime prefix.
This helps test that the final install won't depend on the build files.
=head2 alien_clean_install
alien_clean_install;
Runs C<$build-Eclean_install>, and verifies it did not crash.
=head2 alien_checkpoint_ok
alien_checkpoint_ok;
alien_checkpoint_ok $test_name;
Test the checkpoint of a build.
=head2 alien_resume_ok
alien_resume_ok;
alien_resume_ok $test_name;
Test a resume a checkpointed build.
=head2 alien_rc
alien_rc $code;
Creates C file in a temp directory and sets ALIEN_BUILD_RC. Useful for testing
plugins that should be called from C<~/.alienbuild/rc.pl>. Note that because of the
nature of how the C<~/.alienbuild/rc.pl> file works, you can only use this once!
=head2 alien_subtest
alien_subtest $test_name => sub {
...
};
Clear the build object and clear the build object before and after the subtest.
=head1 SEE ALSO
=over 4
=item L
=item L
=item L
=item L
=back
=head1 AUTHOR
Author: Graham Ollis Eplicease@cpan.orgE
Contributors:
Diab Jerius (DJERIUS)
Roy Storey (KIWIROY)
Ilya Pavlov
David Mertens (run4flat)
Mark Nunberg (mordy, mnunberg)
Christian Walde (Mithaldu)
Brian Wightman (MidLifeXis)
Zaki Mughal (zmughal)
mohawk (mohawk2, ETJ)
Vikas N Kumar (vikasnkumar)
Flavio Poletti (polettix)
Salvador Fandiño (salva)
Gianni Ceccarelli (dakkar)
Pavel Shaydo (zwon, trinitum)
Kang-min Liu (劉康民, gugod)
Nicholas Shipp (nshp)
Juan Julián Merelo Guervós (JJ)
Joel Berger (JBERGER)
Petr Písař (ppisar)
Lance Wicks (LANCEW)
Ahmad Fatoum (a3f, ATHREEF)
José Joaquín Atria (JJATRIA)
Duke Leto (LETO)
Shoichi Kaji (SKAJI)
Shawn Laffan (SLAFFAN)
Paul Evans (leonerd, PEVANS)
Håkon Hægland (hakonhagland, HAKONH)
nick nauwelaerts (INPHOBIA)
Florian Weimer
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2011-2022 by Graham Ollis.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
PK ! 7 yod d Alien/Run.pmnu 6$ package Test::Alien::Run;
use strict;
use warnings;
use 5.008004;
use Test2::API qw( context );
# ABSTRACT: Run object
our $VERSION = '2.80'; # VERSION
sub out { shift->{out} }
sub err { shift->{err} }
sub exit { shift->{exit} }
sub signal { shift->{sig} }
sub success
{
my($self, $message) = @_;
$message ||= 'command succeeded';
my $ok = $self->exit == 0 && $self->signal == 0;
$ok = 0 if $self->{fail};
my $ctx = context();
$ctx->ok($ok, $message);
unless($ok)
{
$ctx->diag(" command exited with @{[ $self->exit ]}") if $self->exit;
$ctx->diag(" command killed with @{[ $self->signal ]}") if $self->signal;
$ctx->diag(" @{[ $self->{fail} ]}") if $self->{fail};
}
$ctx->release;
$self;
}
sub exit_is
{
my($self, $exit, $message) = @_;
$message ||= "command exited with value $exit";
my $ok = $self->exit == $exit;
my $ctx = context();
$ctx->ok($ok, $message);
$ctx->diag(" actual exit value was: @{[ $self->exit ]}") unless $ok;
$ctx->release;
$self;
}
sub exit_isnt
{
my($self, $exit, $message) = @_;
$message ||= "command exited with value not $exit";
my $ok = $self->exit != $exit;
my $ctx = context();
$ctx->ok($ok, $message);
$ctx->diag(" actual exit value was: @{[ $self->exit ]}") unless $ok;
$ctx->release;
$self;
}
sub _like
{
my($self, $regex, $source, $not, $message) = @_;
my $ok = $self->{$source} =~ $regex;
$ok = !$ok if $not;
my $ctx = context();
$ctx->ok($ok, $message);
unless($ok)
{
$ctx->diag(" $source:");
$ctx->diag(" $_") for split /\r?\n/, $self->{$source};
$ctx->diag($not ? ' matches:' : ' does not match:');
$ctx->diag(" $regex");
}
$ctx->release;
$self;
}
sub out_like
{
my($self, $regex, $message) = @_;
$message ||= "output matches $regex";
$self->_like($regex, 'out', 0, $message);
}
sub out_unlike
{
my($self, $regex, $message) = @_;
$message ||= "output does not match $regex";
$self->_like($regex, 'out', 1, $message);
}
sub err_like
{
my($self, $regex, $message) = @_;
$message ||= "standard error matches $regex";
$self->_like($regex, 'err', 0, $message);
}
sub err_unlike
{
my($self, $regex, $message) = @_;
$message ||= "standard error does not match $regex";
$self->_like($regex, 'err', 1, $message);
}
sub note
{
my($self) = @_;
my $ctx = context();
$ctx->note("[cmd]");
$ctx->note(" @{$self->{cmd}}");
if($self->out ne '')
{
$ctx->note("[out]");
$ctx->note(" $_") for split /\r?\n/, $self->out;
}
if($self->err ne '')
{
$ctx->note("[err]");
$ctx->note(" $_") for split /\r?\n/, $self->err;
}
$ctx->release;
$self;
}
sub diag
{
my($self) = @_;
my $ctx = context();
$ctx->diag("[cmd]");
$ctx->diag(" @{$self->{cmd}}");
if($self->out ne '')
{
$ctx->diag("[out]");
$ctx->diag(" $_") for split /\r?\n/, $self->out;
}
if($self->err ne '')
{
$ctx->diag("[err]");
$ctx->diag(" $_") for split /\r?\n/, $self->err;
}
$ctx->release;
$self;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test::Alien::Run - Run object
=head1 VERSION
version 2.80
=head1 SYNOPSIS
use Test2::V0;
use Test::Alien;
run_ok([ $^X, -e => 'print "some output"; exit 22'])
->exit_is(22)
->out_like(qr{some});
=head1 DESCRIPTION
This class stores information about a process run as performed by
L. That function is the I way to create
an instance of this class.
=head1 ATTRIBUTES
=head2 out
my $str = $run->out;
The standard output from the run.
=head2 err
my $str = $run->err;
The standard error from the run.
=head2 exit
my $int = $run->exit;
The exit value of the run.
=head2 signal
my $int = $run->signal;
The signal that killed the run, or zero if the process was terminated normally.
=head1 METHODS
These methods return the run object itself, so they can be chained,
as in the synopsis above.
=head2 success
$run->success;
$run->success($message);
Passes if the process terminated normally with an exit value of 0.
=head2 exit_is
$run->exit_is($exit);
$run->exit_is($exit, $message);
Passes if the process terminated with the given exit value.
=head2 exit_isnt
$run->exit_isnt($exit);
$run->exit_isnt($exit, $message);
Passes if the process terminated with an exit value of anything
but the given value.
=head2 out_like
$run->out_like($regex);
$run->out_like($regex, $message);
Passes if the output of the run matches the given pattern.
=head2 out_unlike
$run->out_unlike($regex);
$run->out_unlike($regex, $message);
Passes if the output of the run does not match the given pattern.
=head2 err_like
$run->err_like($regex);
$run->err_like($regex, $message);
Passes if the standard error of the run matches the given pattern.
=head2 err_unlike
$run->err_unlike($regex);
$run->err_unlike($regex, $message);
Passes if the standard error of the run does not match the given pattern.
=head2 note
$run->note;
Send the output and standard error as test note.
=head2 diag
$run->diag;
Send the output and standard error as test diagnostic.
=head1 SEE ALSO
=over 4
=item L
=back
=head1 AUTHOR
Author: Graham Ollis Eplicease@cpan.orgE
Contributors:
Diab Jerius (DJERIUS)
Roy Storey (KIWIROY)
Ilya Pavlov
David Mertens (run4flat)
Mark Nunberg (mordy, mnunberg)
Christian Walde (Mithaldu)
Brian Wightman (MidLifeXis)
Zaki Mughal (zmughal)
mohawk (mohawk2, ETJ)
Vikas N Kumar (vikasnkumar)
Flavio Poletti (polettix)
Salvador Fandiño (salva)
Gianni Ceccarelli (dakkar)
Pavel Shaydo (zwon, trinitum)
Kang-min Liu (劉康民, gugod)
Nicholas Shipp (nshp)
Juan Julián Merelo Guervós (JJ)
Joel Berger (JBERGER)
Petr Písař (ppisar)
Lance Wicks (LANCEW)
Ahmad Fatoum (a3f, ATHREEF)
José Joaquín Atria (JJATRIA)
Duke Leto (LETO)
Shoichi Kaji (SKAJI)
Shawn Laffan (SLAFFAN)
Paul Evans (leonerd, PEVANS)
Håkon Hægland (hakonhagland, HAKONH)
nick nauwelaerts (INPHOBIA)
Florian Weimer
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2011-2022 by Graham Ollis.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
PK ! t} Alien/CanPlatypus.pmnu 6$ package Test::Alien::CanPlatypus;
use strict;
use warnings;
use 5.008004;
use Test2::API qw( context );
# ABSTRACT: Skip a test file unless FFI::Platypus is available
our $VERSION = '2.80'; # VERSION
sub skip
{
eval { require FFI::Platypus; 1 } ? undef : 'This test requires FFI::Platypus.';
}
sub import
{
my $skip = __PACKAGE__->skip;
return unless defined $skip;
my $ctx = context();
$ctx->plan(0, SKIP => $skip);
$ctx->release;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test::Alien::CanPlatypus - Skip a test file unless FFI::Platypus is available
=head1 VERSION
version 2.80
=head1 SYNOPSIS
use Test::Alien::CanPlatypus;
=head1 DESCRIPTION
This is just a L plugin that requires that L
be available. Otherwise the test will be skipped.
=head1 SEE ALSO
=over 4
=item L
=item L
=back
=head1 AUTHOR
Author: Graham Ollis Eplicease@cpan.orgE
Contributors:
Diab Jerius (DJERIUS)
Roy Storey (KIWIROY)
Ilya Pavlov
David Mertens (run4flat)
Mark Nunberg (mordy, mnunberg)
Christian Walde (Mithaldu)
Brian Wightman (MidLifeXis)
Zaki Mughal (zmughal)
mohawk (mohawk2, ETJ)
Vikas N Kumar (vikasnkumar)
Flavio Poletti (polettix)
Salvador Fandiño (salva)
Gianni Ceccarelli (dakkar)
Pavel Shaydo (zwon, trinitum)
Kang-min Liu (劉康民, gugod)
Nicholas Shipp (nshp)
Juan Julián Merelo Guervós (JJ)
Joel Berger (JBERGER)
Petr Písař (ppisar)
Lance Wicks (LANCEW)
Ahmad Fatoum (a3f, ATHREEF)
José Joaquín Atria (JJATRIA)
Duke Leto (LETO)
Shoichi Kaji (SKAJI)
Shawn Laffan (SLAFFAN)
Paul Evans (leonerd, PEVANS)
Håkon Hægland (hakonhagland, HAKONH)
nick nauwelaerts (INPHOBIA)
Florian Weimer
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2011-2022 by Graham Ollis.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
PK ! `$y y RequiresInternet.pmnu 6$ use strict;
use warnings;
package Test::RequiresInternet;
$Test::RequiresInternet::VERSION = '0.05';
# ABSTRACT: Easily test network connectivity
use Socket;
sub import {
skip_all("NO_NETWORK_TESTING") if env("NO_NETWORK_TESTING");
my $namespace = shift;
my $argc = scalar @_;
if ( $argc == 0 ) {
push @_, 'www.google.com', 80;
}
elsif ( $argc % 2 != 0 ) {
die "Must supply server and a port pairs. You supplied " . (join ", ", @_) . "\n";
}
while ( @_ ) {
my $host = shift;
my $port = shift;
local $@;
eval {make_socket($host, $port)};
if ( $@ ) {
skip_all("$@");
}
}
}
sub make_socket {
my ($host, $port) = @_;
my $portnum;
if ($port =~ /\D/) {
$portnum = getservbyname($port, "tcp");
}
else {
$portnum = $port;
}
die "Could not find a port number for $port\n" if not $portnum;
my $iaddr = inet_aton($host) or die "no host: $host\n";
my $paddr = sockaddr_in($portnum, $iaddr);
my $proto = getprotobyname("tcp");
socket(my $sock, PF_INET, SOCK_STREAM, $proto) or die "socket: $!\n";
connect($sock, $paddr) or die "connect: $!\n";
close ($sock) or die "close: $!\n";
1;
}
sub env {
exists $ENV{$_[0]} && $ENV{$_[0]} eq '1'
}
sub skip_all {
my $reason = shift;
print "1..0 # Skipped: $reason";
exit 0;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test::RequiresInternet - Easily test network connectivity
=head1 VERSION
version 0.05
=head1 SYNOPSIS
use Test::More;
use Test::RequiresInternet ('www.example.com' => 80, 'foobar.io' => 25);
# if you reach here, sockets successfully connected to hosts/ports above
plan tests => 1;
ok(do_that_internet_thing());
=head1 OVERVIEW
This module is intended to easily test network connectivity before functional
tests begin to non-local Internet resources. It does not require any modules
beyond those supplied in core Perl.
If you do not specify a host/port pair, then the module defaults to using
C on port C<80>.
You may optionally specify the port by its name, as in C or C.
If you do this, the test module will attempt to look up the port number
using C.
If you do specify a host and port, they must be specified in B. It is a
fatal error to omit one or the other.
If the environment variable C is set, then the tests
will be skipped without attempting any socket connections.
If the sockets cannot connect to the specified hosts and ports, the exception
is caught, reported and the tests skipped.
=head1 AUTHOR
Mark Allen
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2014 by Mark Allen.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
PK ! PY! ! Needs.pmnu 6$ package Test::Needs;
use strict;
use warnings;
no warnings 'once';
our $VERSION = '0.002010';
$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};
# this allows regexes to match wide characters in vstrings
if ("$]" >= 5.006001 && "$]" <= 5.006002) {
require utf8;
utf8->import;
}
}
our @EXPORT = qw(test_needs);
our $Level = 0;
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 =~ /\ATest::Needs(?:::|\z)/;
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-\x07])(.*)$/s
? sprintf('%d.%03d%03d', ((map ord, /(.)/gs), 0, 0)[0..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 $Level = $Level + 1;
test_needs(@_);
}
no strict 'refs';
*{"${target}::$_"} = \&{"${class}::$_"}
for @{"${class}::EXPORT"};
}
sub test_needs {
my $missing = _find_missing(@_);
local $Level = $Level + 1;
if ($missing) {
if ($ENV{RELEASE_TESTING}) {
_fail("$missing due to RELEASE_TESTING");
}
else {
_skip($missing);
}
}
return 1;
}
sub _skip {
local $Level = $Level + 1;
_fail_or_skip($_[0], 0)
}
sub _fail {
local $Level = $Level + 1;
_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(level => $Level);
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'}) {
local $Test::Builder::Level = $Test::Builder::Level + $Level;
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' } };
my $tests = $tb->current_test;
if ($fail) {
$tb->plan(tests => 1)
unless $tb->$has_plan;
$tests++;
$tb->ok(0, "Test::Needs modules available");
$tb->diag($message);
}
else {
my $plan = $tb->$has_plan;
if ($plan || $tests) {
my $skips
= $plan && $plan ne 'no_plan' ? $plan - $tests : 1;
$tb->skip("Test::Needs modules not available")
for 1 .. $skips;
$tests += $skips;
Test::Builder->can('note') ? $tb->note($message) : print "# $message\n";
}
else {
$tb->skip_all($message);
}
}
$tb->done_testing($tests)
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 $@;
$terminate_event = eval sprintf <<'END_CODE', __LINE__+2, __FILE__ or die "$@";
#line %d "%s"
package # hide
Test::Needs::Event::Terminate;
use Test2::Event ();
our @ISA = qw(Test2::Event);
sub no_display { 1 }
sub terminate { 0 }
__PACKAGE__;
END_CODE
(my $pm = "$terminate_event.pm") =~ s{::}{/}g;
$INC{$pm} = __FILE__;
$terminate_event;
}
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 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 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