Alien-Build/t/alienfile.t
use 5.008004;
use Test2::V0 -no_srand => 1;
use Test::Alien::Build;
use Alien::Build;
use Path::Tiny qw( path );
use lib 'corpus/lib';
use Capture::Tiny qw( capture_merged );
use File::Temp qw( tempdir );
subtest 'compile examples' => sub {
foreach my $alienfile (path('example')->children(qr/\.alienfile$/))
{
my $build = eval {
Alien::Build->load("$alienfile");
};
is $@, '', $alienfile->basename;
}
};
subtest 'non struct alienfile' => sub {
eval {
alienfile q{
use alienfile;
my $foo = 'bar';
@{ "${foo}::${foo}" } = ();
};
};
my $error = $@;
isnt $error, '', 'throws error';
note "error = $error";
};
subtest 'warnings alienfile' => sub {
my $warning = warning {
alienfile q{
use alienfile;
my $foo;
my $bar = "$foo";
};
};
ok $warning;
note $warning;
};
subtest 'plugin' => sub {
subtest 'basic' => sub {
my $build = alienfile q{
use alienfile;
plugin 'RogerRamjet';
};
is(
$build->meta->prop,
hash {
field ramjet => 'roger';
field foo => 22;
field bar => 'something generated';
field baz => undef;
etc;
}
);
};
subtest 'default argument' => sub {
my $build = alienfile q{
use alienfile;
plugin 'RogerRamjet' => 'starscream';
};
is(
$build->meta->prop,
hash {
field ramjet => 'roger';
field foo => 22;
field bar => 'starscream';
field baz => undef;
etc;
}
);
};
subtest 'other arguments' => sub {
my $build = alienfile q{
use alienfile;
plugin 'RogerRamjet' => (
foo => 42,
bar => 'skywarp',
baz => 'megatron',
);
};
is(
$build->meta->prop,
hash {
field ramjet => 'roger';
field foo => 42;
field bar => 'skywarp';
field baz => 'megatron';
etc;
}
);
};
subtest 'sub package' => sub {
my $build = alienfile q{
use alienfile;
plugin 'NesAdvantage::Controller';
};
is($build->meta->prop->{nesadvantage}, 'controller');
};
subtest 'negotiate' => sub {
my $build = alienfile q{
use alienfile;
plugin 'NesAdvantage';
};
is($build->meta->prop->{nesadvantage}, 'negotiate');
};
subtest 'fully qualified class' => sub {
my $build = alienfile q{
use alienfile;
plugin '=Alien::Build::Plugin::RogerRamjet';
};
is(
$build->meta->prop,
hash {
field ramjet => 'roger';
field foo => 22;
field bar => 'something generated';
field baz => undef;
etc;
}
);
};
};
subtest 'probe' => sub {
subtest 'basic' => sub {
my $build = alienfile q{
use alienfile;
probe sub {
my($build) = @_;
$build->install_prop->{called_probe} = 1;
'share';
};
};
is($build->probe, 'share');
is($build->install_prop->{called_probe}, 1);
};
subtest 'wrong block' => sub {
eval {
alienfile q{
use alienfile;
sys {
probe sub { };
};
};
};
like $@, qr/probe must not be in a system block/;
};
};
subtest 'download' => sub {
subtest 'basic' => sub {
my $build = alienfile q{
use alienfile;
use Path::Tiny qw( path );
probe sub { 'share' };
share {
download sub { path('xor-1.00.tar.gz')->touch };
};
};
note capture_merged { $build->download; () };
my $download = path($build->install_prop->{download});
is(
$download->basename,
'xor-1.00.tar.gz',
);
};
subtest 'wrong block' => sub {
eval {
alienfile q{
use alienfile;
sys {
download sub {};
};
};
};
like $@, qr/download must be in a share block/;
};
};
foreach my $hook (qw( fetch decode prefer extract build build_ffi ))
{
subtest "$hook" => sub {
my(undef, $build) = capture_merged {
alienfile qq{
use alienfile;
share {
$hook sub { };
};
};
};
ok( $build->meta->has_hook($hook) );
};
}
subtest 'gather' => sub {
subtest 'configure' => sub {
eval {
alienfile q{
use alienfile;
configure {
gather sub {};
}
};
};
like $@, qr/gather is not allowed in configure block/;
};
subtest 'system + share' => sub {
my $build = alienfile q{
use alienfile;
gather sub {};
};
is( $build->meta->has_hook('gather_system'), T() );
is( $build->meta->has_hook('gather_share'), T() );
};
subtest 'system' => sub {
my $build = alienfile q{
use alienfile;
sys { gather sub {} };
};
is( $build->meta->has_hook('gather_system'), T() );
is( $build->meta->has_hook('gather_share'), F() );
};
subtest 'share' => sub {
my $build = alienfile q{
use alienfile;
share { gather sub {} };
};
is( $build->meta->has_hook('gather_system'), F() );
is( $build->meta->has_hook('gather_share'), T() );
};
subtest 'share + gather_ffi' => sub {
my(undef,$build) = capture_merged {
alienfile q{
use alienfile;
share { gather_ffi sub {} };
};
};
is( $build->meta->has_hook('gather_ffi'), T() );
};
subtest 'share + ffi gather' => sub {
my $build = alienfile q{
use alienfile;
share { ffi { gather sub {} } };
};
is( $build->meta->has_hook('gather_ffi'), T() );
};
subtest 'nada' => sub {
my $build = alienfile q{
use alienfile;
};
is( $build->meta->has_hook('gather_system'), F() );
is( $build->meta->has_hook('gather_share'), F() );
};
};
subtest 'prop' => sub {
my $build = alienfile q{
use alienfile;
meta_prop->{foo1} = 'bar1';
};
is( $build->meta_prop->{foo1}, 'bar1' );
};
subtest 'patch' => sub {
my $build = alienfile q{
use alienfile;
share { patch sub { } };
};
is( $build->meta->has_hook('patch'), T() );
};
subtest 'patch_ffi' => sub {
my(undef,$build) = capture_merged {
alienfile q{
use alienfile;
share { patch_ffi sub { } };
};
};
is( $build->meta->has_hook('patch_ffi'), T() );
};
subtest 'ffi patch' => sub {
my $build = alienfile q{
use alienfile;
share { ffi { patch sub { } } };
};
is( $build->meta->has_hook('patch_ffi'), T() );
};
subtest 'arch' => sub {
subtest 'on' => sub {
my $build = alienfile q{
use alienfile;
meta_prop->{arch} = 1;
};
is( $build->meta_prop->{arch}, T());
};
subtest 'off' => sub {
my $build = alienfile q{
use alienfile;
meta_prop->{arch} = 0;
};
is( $build->meta_prop->{arch}, F());
};
subtest 'default' => sub {
my $build = alienfile q{
use alienfile;
};
is( $build->meta_prop->{arch}, T());
};
};
subtest 'meta' => sub {
my $build = alienfile q{
use alienfile;
meta->prop->{foo} = 1;
probe sub { 'system' };
};
is $build->meta_prop->{foo}, 1;
};
subtest 'test' => sub {
subtest 'basic' => sub {
my $build = alienfile_ok q{
use alienfile;
share {
test [];
};
};
is(
$build->requires('configure'),
hash {
field 'Alien::Build' => '1.14';
etc;
},
);
};
alienfile_ok q{
use alienfile;
sys {
test [];
};
};
alienfile_ok q{
use alienfile;
share {
ffi {
test [];
};
};
};
eval {
alienfile q{
use alienfile;
test [];
};
};
like $@, qr/test is not allowed in any block/, 'not allowed in root block';
eval {
alienfile q{
use alienfile;
configure { test[] };
};
};
like $@, qr/test is not allowed in configure block/, 'not allowed in configure block';
};
subtest 'start_url' => sub {
my $build = alienfile_ok q{
use alienfile;
share {
start_url 'http://bogus.com';
};
};
is(
$build,
object {
call meta_prop => hash {
field start_url => 'http://bogus.com';
etc;
};
call [requires => 'configure'] => hash {
field 'Alien::Build' => '1.19';
etc;
};
},
'build object'
);
};
subtest 'before' => sub {
my $mock = mock 'Alien::Build::Meta' => (
class => 'Alien::Build::Meta',
);
my @before_hook;
$mock->around(before_hook => sub {
my $orig = shift;
my (undef, $name, $code) = @_;
push @before_hook, [$name, $code];
$orig->(@_);
});
$mock->around(new => sub {
my $orig = shift;
@before_hook = ();
$orig->(@_);
});
subtest 'before build in share' => sub {
my $build = alienfile_ok q{
use alienfile;
share {
before 'build' => sub {
return 42;
};
build [];
};
};
is $before_hook[0][0], 'build';
ok($build->requires('configure')->{'Alien::Build'} >= '1.40', 'before directive requires 1.40');
};
subtest 'before build in share>ffi' => sub {
my $build = alienfile_ok q{
use alienfile;
share {
ffi {
before 'build' => sub {
return 42;
};
build [];
};
};
};
is $before_hook[0][0], 'build_ffi';
};
subtest 'before probe in any' => sub {
my $build = alienfile_ok q{
use alienfile;
before 'probe' => sub {};
probe [];
};
is $before_hook[0][0], 'probe';
};
subtest 'before gather any' => sub {
my $build = alienfile_ok q{
use alienfile;
before 'gather' => sub {};
gather [];
};
is $before_hook[1][0], 'gather_system';
is $before_hook[0][0], 'gather_share';
};
subtest 'before gather share' => sub {
my $build = alienfile_ok q{
use alienfile;
share {
before 'gather' => sub {};
gather [];
};
};
is $before_hook[0][0], 'gather_share';
};
subtest 'before gather ffi' => sub {
my $build = alienfile_ok q{
use alienfile;
share {
ffi {
before 'gather' => sub {};
gather [];
};
};
};
is $before_hook[0][0], 'gather_ffi';
};
subtest 'before gather system' => sub {
my $build = alienfile_ok q{
use alienfile;
sys {
before 'gather' => sub {};
gather [];
};
};
is $before_hook[0][0], 'gather_system';
};
subtest 'before build in sys' => sub {
eval {
alienfile q{
use alienfile;
sys {
before 'build' => sub {
return 42;
};
build [];
};
};
};
like $@, qr/before build is not allowed in sys block/, 'not allowed in sys block';
};
subtest 'before second argument must be a code ref' => sub {
eval {
alienfile q{
use alienfile;
share {
before 'build' => 1;
build [];
};
};
};
like $@, qr/before build argument must be a code reference/, 'must be code reference';
};
subtest 'arbitrary stages not allowed' => sub {
eval {
alienfile q{
use alienfile;
share {
before 'bogus' => sub {};
build [];
};
};
};
like $@, qr/No such stage bogus/, 'no bogus allowed';
};
};
subtest 'after' => sub {
my $mock = mock 'Alien::Build::Meta' => (
class => 'Alien::Build::Meta',
);
my @after_hook;
$mock->around(after_hook => sub {
my $orig = shift;
my (undef, $name, $code) = @_;
push @after_hook, [$name, $code];
$orig->(@_);
});
$mock->around(new => sub {
my $orig = shift;
@after_hook = ();
$orig->(@_);
});
subtest 'after build in share' => sub {
my $build = alienfile_ok q{
use alienfile;
share {
after 'build' => sub {
return 42;
};
build [];
};
};
is $after_hook[0][0], 'build';
ok($build->requires('configure')->{'Alien::Build'} >= '1.40', 'after directive requires 1.40');
};
subtest 'after build in share>ffi' => sub {
my $build = alienfile_ok q{
use alienfile;
share {
ffi {
after 'build' => sub {
return 42;
};
build [];
};
};
};
is $after_hook[0][0], 'build_ffi';
};
subtest 'after probe in any' => sub {
my $build = alienfile_ok q{
use alienfile;
after 'probe' => sub {};
probe [];
};
is $after_hook[0][0], 'probe';
};
subtest 'after gather any' => sub {
my $build = alienfile_ok q{
use alienfile;
after 'gather' => sub {};
gather [];
};
is $after_hook[1][0], 'gather_system';
is $after_hook[0][0], 'gather_share';
};
subtest 'after gather share' => sub {
my $build = alienfile_ok q{
use alienfile;
share {
after 'gather' => sub {};
gather [];
};
};
is $after_hook[0][0], 'gather_share';
};
subtest 'after gather ffi' => sub {
my $build = alienfile_ok q{
use alienfile;
share {
ffi {
after 'gather' => sub {};
gather [];
};
};
};
is $after_hook[0][0], 'gather_ffi';
};
subtest 'after gather system' => sub {
my $build = alienfile_ok q{
use alienfile;
sys {
after 'gather' => sub {};
gather [];
};
};
is $after_hook[0][0], 'gather_system';
};
subtest 'after build in sys' => sub {
eval {
alienfile q{
use alienfile;
sys {
after 'build' => sub {
return 42;
};
build [];
};
};
};
like $@, qr/after build is not allowed in sys block/, 'not allowed in sys block';
};
subtest 'after second argument must be a code ref' => sub {
eval {
alienfile q{
use alienfile;
share {
after 'build' => 1;
build [];
};
};
};
like $@, qr/after build argument must be a code reference/, 'must be code reference';
};
subtest 'arbitrary stages not allowed' => sub {
eval {
alienfile q{
use alienfile;
share {
after 'bogus' => sub {};
build [];
};
};
};
like $@, qr/No such stage bogus/, 'no bogus allowed';
};
};
subtest 'digest' => sub {
local $Alien::Build::VERSION = $Alien::Build::VERSION || 2.57;
my $build = alienfile_ok q{
use alienfile;
digest SHA256 => 'a7e79996a02d3dfc47f6f3ec043c67690dc06a10d091bf1d760fee7c8161391a';
plugin 'Fetch::Local';
probe sub { 'share' };
};
alienfile_skip_if_missing_prereqs;
is
$build->fetch('corpus/alien_build_plugin_digest_shapp/foo.txt.gz'),
hash {
field type => 'file';
field filename => 'foo.txt.gz';
etc;
},
'fetch works with good sig';
is
dies { $build->fetch(__FILE__) },
match qr/SHA256 digest does not match/,
'fetch dies with bad sig';
};
done_testing;