package Alien::Build;
use strict;
use warnings;
use 5.008004;
use Path::Tiny ();
use Carp ();
use File::chdir;
use JSON::PP ();
use Env qw( @PATH @PKG_CONFIG_PATH );
use Config ();
use Alien::Build::Log;
# ABSTRACT: Build external dependencies for use in CPAN
our $VERSION = '2.84'; # VERSION
sub _path { goto \&Path::Tiny::path }
sub new
{
my($class, %args) = @_;
my $self = bless {
install_prop => {
root => _path($args{root} || "_alien")->absolute->stringify,
patch => (defined $args{patch}) ? _path($args{patch})->absolute->stringify : undef,
},
runtime_prop => {
alien_build_version => $Alien::Build::VERSION || 'dev',
},
plugin_instance_prop => {},
bin_dir => [],
pkg_config_path => [],
aclocal_path => [],
}, $class;
# force computing this as soon as possible
$self->download_rule;
$self->meta->filename(
$args{filename} || do {
my(undef, $filename) = caller;
_path($filename)->absolute->stringify;
}
);
if($args{meta_prop})
{
$self->meta->prop->{$_} = $args{meta_prop}->{$_} for keys %{ $args{meta_prop} };
}
$self;
}
my $count = 0;
sub load
{
my(undef, $alienfile, @args) = @_;
my $rcfile = Path::Tiny->new($ENV{ALIEN_BUILD_RC} || '~/.alienbuild/rc.pl')->absolute;
if(-r $rcfile)
{
require Alien::Build::rc;
package Alien::Build::rc;
require $rcfile;
}
unless(-r $alienfile)
{
Carp::croak "Unable to read alienfile: $alienfile";
}
my $file = _path $alienfile;
my $name = $file->parent->basename;
$name =~ s/^alien-//i;
$name =~ s/[^a-z]//g;
$name = 'x' if $name eq '';
$name = ucfirst $name;
my $class = "Alien::Build::Auto::$name@{[ $count++ ]}";
{ no strict 'refs';
@{ "${class}::ISA" } = ('Alien::Build');
*{ "${class}::Alienfile::meta" } = sub {
$class =~ s{::Alienfile$}{};
$class->meta;
}};
my @preload = qw( Core::Setup Core::Download Core::FFI Core::Override Core::CleanInstall );
push @preload, @Alien::Build::rc::PRELOAD;
push @preload, split /;/, $ENV{ALIEN_BUILD_PRELOAD}
if defined $ENV{ALIEN_BUILD_PRELOAD};
my @postload = qw( Core::Legacy Core::Gather Core::Tail );
push @postload, @Alien::Build::rc::POSTLOAD;
push @postload, split /;/, $ENV{ALIEN_BUILD_POSTLOAD}
if defined $ENV{ALIEN_BUILD_POSTLOAD};
my $self = $class->new(
filename => $file->absolute->stringify,
@args,
);
require alienfile;
foreach my $preload (@preload)
{
ref $preload eq 'CODE' ? $preload->($self->meta) : $self->meta->apply_plugin($preload);
}
# TODO: do this without a string eval ?
## no critic
eval '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) . qq{
package ${class}::Alienfile;
do '@{[ $file->absolute->stringify ]}';
die \$\@ if \$\@;
};
die $@ if $@;
## use critic
foreach my $postload (@postload)
{
ref $postload eq 'CODE' ? $postload->($self->meta) : $self->meta->apply_plugin($postload);
}
$self->{args} = \@args;
unless(defined $self->meta->prop->{arch})
{
$self->meta->prop->{arch} = 1;
}
unless(defined $self->meta->prop->{network})
{
$self->meta->prop->{network} = 1;
## https://github.com/PerlAlien/Alien-Build/issues/23#issuecomment-341114414
#$self->meta->prop->{network} = 0 if $ENV{NO_NETWORK_TESTING};
$self->meta->prop->{network} = 0 if (defined $ENV{ALIEN_INSTALL_NETWORK}) && ! $ENV{ALIEN_INSTALL_NETWORK};
}
unless(defined $self->meta->prop->{local_source})
{
if(! defined $self->meta->prop->{start_url})
{
$self->meta->prop->{local_source} = 0;
}
# we assume URL schemes are at least two characters, that
# way Windows absolute paths can be used as local start_url
elsif($self->meta->prop->{start_url} =~ /^([a-z]{2,}):/i)
{
my $scheme = $1;
$self->meta->prop->{local_source} = $scheme eq 'file';
}
else
{
$self->meta->prop->{local_source} = 1;
}
}
return $self;
}
sub resume
{
my(undef, $alienfile, $root) = @_;
my $h = JSON::PP::decode_json(_path("$root/state.json")->slurp);
my $self = Alien::Build->load("$alienfile", @{ $h->{args} });
$self->{install_prop} = $h->{install};
$self->{plugin_instance_prop} = $h->{plugin_instance};
$self->{runtime_prop} = $h->{runtime};
$self;
}
sub meta_prop
{
my($class) = @_;
$class->meta->prop;
}
sub install_prop
{
shift->{install_prop};
}
sub plugin_instance_prop
{
my($self, $plugin) = @_;
my $instance_id = $plugin->instance_id;
$self->{plugin_instance_prop}->{$instance_id} ||= {};
}
sub runtime_prop
{
shift->{runtime_prop};
}
sub hook_prop
{
shift->{hook_prop};
}
sub _command_prop
{
my($self) = @_;
return {
alien => {
install => $self->install_prop,
runtime => $self->runtime_prop,
hook => $self->hook_prop,
meta => $self->meta_prop,
},
perl => {
config => \%Config::Config,
},
env => \%ENV,
};
}
sub checkpoint
{
my($self) = @_;
my $root = $self->root;
_path("$root/state.json")->spew(
JSON::PP->new->pretty->canonical(1)->ascii->encode({
install => $self->install_prop,
runtime => $self->runtime_prop,
plugin_instance => $self->{plugin_instance_prop},
args => $self->{args},
})
);
$self;
}
sub root
{
my($self) = @_;
my $root = $self->install_prop->{root};
_path($root)->mkpath unless -d $root;
$root;
}
sub install_type
{
my($self) = @_;
$self->{runtime_prop}->{install_type} ||= $self->probe;
}
sub is_system_install
{
my($self) = @_;
$self->install_type eq 'system';
}
sub is_share_install
{
my($self) = @_;
$self->install_type eq 'share';
}
sub download_rule
{
my($self) = @_;
$self->install_prop->{download_rule} ||= do {
my $dr = $ENV{ALIEN_DOWNLOAD_RULE};
$dr = 'warn' unless defined $dr;
$dr = 'warn' if $dr eq 'default';
unless($dr =~ /^(warn|digest|encrypt|digest_or_encrypt|digest_and_encrypt)$/)
{
$self->log("unknown ALIEN_DOWNLOAD_RULE \"$dr\", using \"warn\" instead");
$dr = 'warn';
}
$dr;
};
}
sub set_prefix
{
my($self, $prefix) = @_;
if($self->meta_prop->{destdir})
{
$self->runtime_prop->{prefix} =
$self->install_prop->{prefix} = $prefix;
}
else
{
$self->runtime_prop->{prefix} = $prefix;
$self->install_prop->{prefix} = $self->install_prop->{stage};
}
}
sub set_stage
{
my($self, $dir) = @_;
$self->install_prop->{stage} = $dir;
}
sub _merge
{
my %h;
while(@_)
{
my $mod = shift;
my $ver = shift;
if((!defined $h{$mod}) || $ver > $h{$mod})
{ $h{$mod} = $ver }
}
\%h;
}
sub requires
{
my($self, $phase) = @_;
$phase ||= 'any';
my $meta = $self->meta;
$phase =~ /^(?:any|configure)$/
? $meta->{require}->{$phase} || {}
: _merge %{ $meta->{require}->{any} }, %{ $meta->{require}->{$phase} };
}
sub load_requires
{
my($self, $phase, $eval) = @_;
my $reqs = $self->requires($phase);
foreach my $mod (keys %$reqs)
{
my $ver = $reqs->{$mod};
my $check = sub {
my $pm = "$mod.pm";
$pm =~ s{::}{/}g;
require $pm;
};
if($eval)
{
eval { $check->() };
die "Required $mod @{[ $ver || 'undef' ]}, missing" if $@;
}
else
{
$check->();
}
# note Test::Alien::Build#alienfile_skip_if_missing_prereqs does a regex
# on this diagnostic, so if you change it here, change it there too.
die "Required $mod $ver, have @{[ $mod->VERSION || 0 ]}" if $ver && ! $mod->VERSION($ver);
# allow for requires on Alien::Build or Alien::Base
next if $mod eq 'Alien::Build';
next if $mod eq 'Alien::Base';
if($mod->can('bin_dir'))
{
push @{ $self->{bin_dir} }, $mod->bin_dir;
}
if(($mod->can('runtime_prop') && $mod->runtime_prop)
|| ($mod->isa('Alien::Base') && $mod->install_type('share')))
{
for my $dir (qw(lib share)) {
my $path = _path($mod->dist_dir)->child("$dir/pkgconfig");
if(-d $path)
{
push @{ $self->{pkg_config_path} }, $path->stringify;
}
}
my $path = _path($mod->dist_dir)->child('share/aclocal');
if(-d $path)
{
$path = "$path";
if($^O eq 'MSWin32')
{
# convert to MSYS path
$path =~ s{^([a-z]):}{/$1/}i;
}
push @{ $self->{aclocal_path} }, $path;
}
}
# sufficiently new Autotools have a aclocal_dir which will
# give us the directories we need.
if($mod eq 'Alien::Autotools' && $mod->can('aclocal_dir'))
{
push @{ $self->{aclocal_path} }, $mod->aclocal_dir;
}
if($mod->can('alien_helper'))
{
my $helpers = $mod->alien_helper;
foreach my $name (sort keys %$helpers)
{
my $code = $helpers->{$name};
$self->meta->interpolator->replace_helper($name => $code);
}
}
}
1;
}
sub _call_hook
{
my $self = shift;
local $ENV{PATH} = $ENV{PATH};
unshift @PATH, @{ $self->{bin_dir} };
local $ENV{PKG_CONFIG_PATH} = $ENV{PKG_CONFIG_PATH};
unshift @PKG_CONFIG_PATH, @{ $self->{pkg_config_path} };
local $ENV{ACLOCAL_PATH} = $ENV{ACLOCAL_PATH};
# autoconf uses MSYS paths, even for the ACLOCAL_PATH environment variable, so we can't use Env for this.
{
my @path;
@path = split /:/, $ENV{ACLOCAL_PATH} if defined $ENV{ACLOCAL_PATH};
unshift @path, @{ $self->{aclocal_path} };
$ENV{ACLOCAL_PATH} = join ':', @path;
}
my $config = ref($_[0]) eq 'HASH' ? shift : {};
my($name, @args) = @_;
local $self->{hook_prop} = {};
$self->meta->call_hook( $config, $name => $self, @args );
}
sub probe
{
my($self) = @_;
local $CWD = $self->root;
my $dir;
my $env = $self->_call_hook('override');
my $type;
my $error;
$env = '' if $env eq 'default';
if($env eq 'share')
{
$type = 'share';
}
else
{
$type = eval {
$self->_call_hook(
{
before => sub {
$dir = Alien::Build::TempDir->new($self, "probe");
$CWD = "$dir";
},
after => sub {
$CWD = $self->root;
},
ok => 'system',
continue => sub {
if($_[0] eq 'system')
{
foreach my $name (qw( probe_class probe_instance_id ))
{
if(exists $self->hook_prop->{$name} && defined $self->hook_prop->{$name})
{
$self->install_prop->{"system_$name"} = $self->hook_prop->{$name};
}
}
return undef;
}
else
{
return 1;
}
},
},
'probe',
);
};
$error = $@;
$type = 'share' unless defined $type;
}
if($error)
{
if($env eq 'system')
{
die $error;
}
$self->log("error in probe (will do a share install): $@");
$self->log("Don't panic, we will attempt a share build from source if possible.");
$self->log("Do not file a bug unless you expected a system install to succeed.");
$type = 'share';
}
if($env && $env ne $type)
{
die "requested $env install not available";
}
if($type !~ /^(system|share)$/)
{
Carp::croak "probe hook returned something other than system or share: $type";
}
if($type eq 'share' && (!$self->meta_prop->{network}) && (!$self->meta_prop->{local_source}))
{
$self->log("install type share requested or detected, but network fetch is turned off");
$self->log("see https://metacpan.org/pod/Alien::Build::Manual::FAQ#Network-fetch-is-turned-off");
Carp::croak "network fetch is turned off";
}
$self->runtime_prop->{install_type} = $type;
$type;
}
sub download
{
my($self) = @_;
return $self unless $self->install_type eq 'share';
return $self if $self->install_prop->{complete}->{download};
if($self->meta->has_hook('download'))
{
my $tmp;
local $CWD;
my $valid = 0;
$self->_call_hook(
{
before => sub {
$tmp = Alien::Build::TempDir->new($self, "download");
$CWD = "$tmp";
},
verify => sub {
my @list = grep { $_->basename !~ /^\./, } _path('.')->children;
my $count = scalar @list;
if($count == 0)
{
die "no files downloaded";
}
elsif($count == 1)
{
my($archive) = $list[0];
if(-d $archive)
{
# TODO: this is probably a bug that we don't set
# download or compelte properties?
$self->log("single dir, assuming directory");
}
else
{
$self->log("single file, assuming archive");
}
$self->install_prop->{download} = $archive->absolute->stringify;
$self->install_prop->{complete}->{download} = 1;
$valid = 1;
}
else
{
$self->log("multiple files, assuming directory");
$self->install_prop->{complete}->{download} = 1;
$self->install_prop->{download} = _path('.')->absolute->stringify;
$valid = 1;
}
},
after => sub {
$CWD = $self->root;
},
},
'download',
);
# experimental and undocumented for now
if($self->meta->has_hook('check_download'))
{
$self->meta->call_hook(check_download => $self);
}
return $self if $valid;
}
else
{
# This will call the default download hook
# defined in Core::Download since the recipe
# does not provide a download hook
my $ret = $self->_call_hook('download');
# experimental and undocumented for now
if($self->meta->has_hook('check_download'))
{
$self->meta->call_hook(check_download => $self);
}
return $self;
}
die "download failed";
}
sub fetch
{
my $self = shift;
my $url = $_[0] || $self->meta_prop->{start_url};
my $secure = 0;
if(defined $url && ($url =~ /^(https|file):/ || $url !~ /:/))
{
# considered secure when either https or a local file
$secure = 1;
}
elsif(!defined $url)
{
$self->log("warning: undefined url in fetch");
}
else
{
$self->log("warning: attempting to fetch a non-TLS or bundled URL: @{[ $url ]}");
}
die "insecure fetch is not allowed" if $self->download_rule =~ /^(encrypt|digest_and_encrypt)$/ && !$secure;
my $file = $self->_call_hook( 'fetch' => @_ );
$secure = 0;
if(ref($file) ne 'HASH')
{
$self->log("warning: fetch returned non-hash reference");
}
elsif(!defined $file->{protocol})
{
$self->log("warning: fetch did not return a protocol");
}
elsif($file->{protocol} !~ /^(https|file)$/)
{
$self->log("warning: fetch did not use a secure protocol: @{[ $file->{protocol} ]}");
}
else
{
$secure = 1;
}
die "insecure fetch is not allowed" if $self->download_rule =~ /^(encrypt|digest_and_encrypt)$/ && !$secure;
$file;
}
sub check_digest
{
my($self, $file) = @_;
return '' unless $self->meta_prop->{check_digest};
unless(ref($file) eq 'HASH')
{
my $path = Path::Tiny->new($file);
$file = {
type => 'file',
filename => $path->basename,
path => "$path",
tmp => 0,
};
}
my $path = $file->{path};
if(defined $path)
{
# there is technically a race condition here
die "Missing file in digest check: @{[ $file->{filename} ]}" unless -f $path;
die "Unreadable file in digest check: @{[ $file->{filename} ]}" unless -r $path;
}
else
{
die "File is wrong type" unless defined $file->{type} && $file->{type} eq 'file';
die "File has no filename" unless defined $file->{filename};
die "@{[ $file->{filename} ]} has no content" unless defined $file->{content};
}
my $filename = $file->{filename};
my $signature = $self->meta_prop->{digest}->{$filename} || $self->meta_prop->{digest}->{'*'};
die "No digest for $filename" unless defined $signature && ref $signature eq 'ARRAY';
my($algo, $expected) = @$signature;
if($self->meta->call_hook( check_digest => $self, $file, $algo, $expected ))
{
# record the verification here so that we can check in the extract step that the signature
# was checked.
$self->install_prop->{download_detail}->{$path}->{digest} = [$algo, $expected] if defined $path; return 1;
}
else
{
die "No plugin provides digest algorithm for $algo";
}
}
sub decode
{
my($self, $res) = @_;
my $res2 = $self->_call_hook( decode => $res );
$res2->{protocol} = $res->{protocol}
if !defined $res2->{protocol}
&& defined $res->{protocol};
return $res2;
}
sub prefer
{
my($self, $res) = @_;
my $res2 = $self->_call_hook( prefer => $res );
$res2->{protocol} = $res->{protocol}
if !defined $res2->{protocol}
&& defined $res->{protocol};
return $res2;
}
sub extract
{
my($self, $archive) = @_;
$archive ||= $self->install_prop->{download};
unless(defined $archive)
{
die "tried to call extract before download";
}
{
my $checked_digest = 0;
my $encrypted_fetch = 0;
my $detail = $self->install_prop->{download_detail}->{$archive};
if(defined $detail)
{
if(defined $detail->{digest})
{
my($algo, $expected) = @{ $detail->{digest} };
my $file = {
type => 'file',
filename => Path::Tiny->new($archive)->basename,
path => $archive,
tmp => 0,
};
$checked_digest = $self->meta->call_hook( check_digest => $self, $file, $algo, $expected )
}
if(!defined $detail->{protocol})
{
$self->log("warning: extract did not receive protocol details for $archive") unless $checked_digest;
}
elsif($detail->{protocol} !~ /^(https|file)$/)
{
$self->log("warning: extracting from a file that was fetched via insecure protocol @{[ $detail->{protocol} ]}") unless $checked_digest ;
}
else
{
$encrypted_fetch = 1;
}
}
else
{
$self->log("warning: extract received no download details for $archive");
}
if($self->download_rule eq 'digest')
{
die "required digest missing for $archive" unless $checked_digest;
}
elsif($self->download_rule eq 'encrypt')
{
die "file was fetched insecurely for $archive" unless $encrypted_fetch;
}
elsif($self->download_rule eq 'digest_or_encrypt')
{
die "file was fetched insecurely and required digest missing for $archive" unless $checked_digest || $encrypted_fetch;
}
elsif($self->download_rule eq 'digest_and_encrypt')
{
die "file was fetched insecurely and required digest missing for $archive" unless $checked_digest || $encrypted_fetch;
die "required digest missing for $archive" unless $checked_digest;
die "file was fetched insecurely for $archive" unless $encrypted_fetch;
}
elsif($self->download_rule eq 'warn')
{
unless($checked_digest || $encrypted_fetch)
{
$self->log("!!! NOTICE OF FUTURE CHANGE IN BEHAVIOR !!!");
$self->log("a future version of Alien::Build will die here by default with this exception: file was fetched insecurely and required digest missing for $archive");
$self->log("!!! NOTICE OF FUTURE CHANGE IN BEHAVIOR !!!");
}
}
else
{
die "internal error, unknown download rule: @{[ $self->download_rule ]}";
}
}
my $nick_name = 'build';
if($self->meta_prop->{out_of_source})
{
$nick_name = 'extract';
my $extract = $self->install_prop->{extract};
return $extract if defined $extract && -d $extract;
}
my $tmp;
local $CWD;
my $ret;
$self->_call_hook({
before => sub {
# called build instead of extract, because this
# will be used for the build step, and technically
# extract is a substage of build anyway.
$tmp = Alien::Build::TempDir->new($self, $nick_name);
$CWD = "$tmp";
},
verify => sub {
my $path = '.';
if($self->meta_prop->{out_of_source} && $self->install_prop->{extract})
{
$path = $self->install_prop->{extract};
}
my @list = grep { $_->basename !~ /^\./ && $_->basename ne 'pax_global_header' } _path($path)->children;
my $count = scalar @list;
if($count == 0)
{
die "no files extracted";
}
elsif($count == 1 && -d $list[0])
{
$ret = $list[0]->absolute->stringify;
}
else
{
$ret = "$tmp";
}
},
after => sub {
$CWD = $self->root;
},
}, 'extract', $archive);
$self->install_prop->{extract} ||= $ret;
$ret ? $ret : ();
}
sub build
{
my($self) = @_;
# save the evironment, in case some plugins decide
# to alter it. Or us! See just a few lines below.
local %ENV = %ENV;
my $stage = _path($self->install_prop->{stage});
$stage->mkpath;
my $tmp;
if($self->install_type eq 'share')
{
foreach my $suffix ('', '_ffi')
{
local $CWD;
delete $ENV{DESTDIR} unless $self->meta_prop->{destdir};
my %env_meta = %{ $self->meta_prop ->{env} || {} };
my %env_inst = %{ $self->install_prop->{env} || {} };
if($self->meta_prop->{env_interpolate})
{
foreach my $key (keys %env_meta)
{
$env_meta{$key} = $self->meta->interpolator->interpolate($env_meta{$key}, $self);
}
}
%ENV = (%ENV, %env_meta);
%ENV = (%ENV, %env_inst);
my $destdir;
$self->_call_hook(
{
before => sub {
if($self->meta_prop->{out_of_source})
{
$self->extract;
$CWD = $tmp = Alien::Build::TempDir->new($self, 'build');
}
else
{
$CWD = $tmp = $self->extract;
}
if($self->meta_prop->{destdir})
{
$destdir = Alien::Build::TempDir->new($self, 'destdir');
$ENV{DESTDIR} = "$destdir";
}
$self->_call_hook({ all => 1 }, "patch${suffix}");
},
after => sub {
$destdir = "$destdir" if $destdir;
},
}, "build${suffix}");
$self->install_prop->{"_ab_build@{[ $suffix || '_share' ]}"} = "$CWD";
$self->_call_hook("gather@{[ $suffix || '_share' ]}");
}
}
elsif($self->install_type eq 'system')
{
local $CWD = $self->root;
my $dir;
$self->_call_hook(
{
before => sub {
$dir = Alien::Build::TempDir->new($self, "gather");
$CWD = "$dir";
},
after => sub {
$CWD = $self->root;
},
},
'gather_system',
);
$self->install_prop->{finished} = 1;
$self->install_prop->{complete}->{gather_system} = 1;
}
$self;
}
sub test
{
my($self) = @_;
if($self->install_type eq 'share')
{
foreach my $suffix ('_share', '_ffi')
{
if($self->meta->has_hook("test$suffix"))
{
my $dir = $self->install_prop->{"_ab_build$suffix"};
Carp::croak("no build directory to run tests") unless $dir && -d $dir;
local $CWD = $dir;
$self->_call_hook("test$suffix");
}
}
}
else
{
if($self->meta->has_hook("test_system"))
{
my $dir = Alien::Build::TempDir->new($self, "test");
local $CWD = "$dir";
$self->_call_hook("test_system");
}
}
}
sub clean_install
{
my($self) = @_;
if($self->install_type eq 'share')
{
$self->_call_hook("clean_install");
}
}
sub system
{
my($self, $command, @args) = @_;
my $prop = $self->_command_prop;
($command, @args) = map {
$self->meta->interpolator->interpolate($_, $prop)
} ($command, @args);
$self->log("+ $command @args");
scalar @args
? system $command, @args
: system $command;
}
sub log
{
my(undef, $message) = @_;
my $caller = [caller];
chomp $message;
foreach my $line (split /\n/, $message)
{
Alien::Build::Log->default->log(
caller => $caller,
message => $line,
);
}
}
{
my %meta;
sub meta
{
my($class) = @_;
$class = ref $class if ref $class;
$meta{$class} ||= Alien::Build::Meta->new( class => $class );
}
}
package Alien::Build::Meta;
our @CARP_NOT = qw( alienfile );
sub new
{
my($class, %args) = @_;
my $self = bless {
phase => 'any',
build_suffix => '',
require => {
any => {},
share => {},
system => {},
},
around => {},
prop => {},
%args,
}, $class;
$self;
}
sub prop
{
shift->{prop};
}
sub filename
{
my($self, $new) = @_;
$self->{filename} = $new if defined $new;
$self->{filename};
}
sub add_requires
{
my $self = shift;
my $phase = shift;
while(@_)
{
my $module = shift;
my $version = shift;
my $old = $self->{require}->{$phase}->{$module};
if((!defined $old) || $version > $old)
{ $self->{require}->{$phase}->{$module} = $version }
}
$self;
}
sub interpolator
{
my($self, $new) = @_;
if(defined $new)
{
if(defined $self->{intr})
{
Carp::croak "tried to set interpolator twice";
}
if(ref $new)
{
$self->{intr} = $new;
}
else
{
$self->{intr} = $new->new;
}
}
elsif(!defined $self->{intr})
{
require Alien::Build::Interpolate::Default;
$self->{intr} = Alien::Build::Interpolate::Default->new;
}
$self->{intr};
}
sub has_hook
{
my($self, $name) = @_;
defined $self->{hook}->{$name};
}
sub _instr
{
my($self, $name, $instr) = @_;
if(ref($instr) eq 'CODE')
{
return $instr;
}
elsif(ref($instr) eq 'ARRAY')
{
my %phase = (
download => 'share',
fetch => 'share',
decode => 'share',
prefer => 'share',
extract => 'share',
patch => 'share',
patch_ffi => 'share',
build => 'share',
build_ffi => 'share',
stage => 'share',
gather_ffi => 'share',
gather_share => 'share',
gather_system => 'system',
test_ffi => 'share',
test_share => 'share',
test_system => 'system',
);
require Alien::Build::CommandSequence;
my $seq = Alien::Build::CommandSequence->new(@$instr);
$seq->apply_requirements($self, $phase{$name} || 'any');
return $seq;
}
else
{
Carp::croak "type not supported as a hook";
}
}
sub register_hook
{
my($self, $name, $instr) = @_;
push @{ $self->{hook}->{$name} }, _instr $self, $name, $instr;
$self;
}
sub default_hook
{
my($self, $name, $instr) = @_;
$self->{default_hook}->{$name} = _instr $self, $name, $instr;
$self;
}
sub around_hook
{
my($self, $name, $code) = @_;
if(my $old = $self->{around}->{$name})
{
# this is the craziest shit I have ever
# come up with.
$self->{around}->{$name} = sub {
my $orig = shift;
$code->(sub { $old->($orig, @_) }, @_);
};
}
else
{
$self->{around}->{$name} = $code;
}
}
sub after_hook
{
my($self, $name, $code) = @_;
$self->around_hook(
$name => sub {
my $orig = shift;
my $ret = $orig->(@_);
$code->(@_);
$ret;
}
);
}
sub before_hook
{
my($self, $name, $code) = @_;
$self->around_hook(
$name => sub {
my $orig = shift;
$code->(@_);
my $ret = $orig->(@_);
$ret;
}
);
}
sub call_hook
{
my $self = shift;
my %args = ref $_[0] ? %{ shift() } : ();
my($name, @args) = @_;
my $error;
my @hooks = @{ $self->{hook}->{$name} || []};
if(@hooks == 0)
{
if(defined $self->{default_hook}->{$name})
{
@hooks = ($self->{default_hook}->{$name})
}
elsif(!$args{all})
{
Carp::croak "No hooks registered for $name";
}
}
my $value;
foreach my $hook (@hooks)
{
if(eval { $args[0]->isa('Alien::Build') })
{
%{ $args[0]->{hook_prop} } = (
name => $name,
);
}
my $wrapper = $self->{around}->{$name} || sub { my $code = shift; $code->(@_) };
my $value;
$args{before}->() if $args{before};
if(ref($hook) eq 'CODE')
{
$value = eval {
my $value = $wrapper->(sub { $hook->(@_) }, @args);
$args{verify}->('code') if $args{verify};
$value;
};
}
else
{
$value = $wrapper->(sub {
eval {
$hook->execute(@_);
$args{verify}->('command') if $args{verify};
};
defined $args{ok} ? $args{ok} : 1;
}, @args);
}
$error = $@;
$args{after}->() if $args{after};
if($args{all})
{
die if $error;
}
else
{
next if $error;
next if $args{continue} && $args{continue}->($value);
return $value;
}
}
die $error if $error && ! $args{all};
$value;
}
sub apply_plugin
{
my($self, $name, @args) = @_;
my $class;
my $pm;
my $found;
if($name =~ /^=(.*)$/)
{
$class = $1;
$pm = "$class.pm";
$pm =~ s!::!/!g;
$found = 1;
}
if($name !~ /::/ && !$found)
{
foreach my $inc (@INC)
{
# TODO: allow negotiators to work with @INC hooks
next if ref $inc;
my $file = Path::Tiny->new("$inc/Alien/Build/Plugin/$name/Negotiate.pm");
if(-r $file)
{
$class = "Alien::Build::Plugin::${name}::Negotiate";
$pm = "Alien/Build/Plugin/$name/Negotiate.pm";
$found = 1;
last;
}
}
}
unless($found)
{
$class = "Alien::Build::Plugin::$name";
$pm = "Alien/Build/Plugin/$name.pm";
$pm =~ s{::}{/}g;
}
require $pm unless $class->can('new');
my $plugin = $class->new(@args);
$plugin->init($self);
$self;
}
package Alien::Build::TempDir;
# TODO: it's confusing that there is both a AB::TempDir and AB::Temp
# although they do different things. there could maybe be a better
# name for AB::TempDir (maybe AB::TempBuildDir, though that is a little
# redundant). Happily both are private classes, and either are able to
# rename, if a good name can be thought of.
use overload '""' => sub { shift->as_string }, bool => sub { 1 }, fallback => 1;
use File::Temp qw( tempdir );
sub new
{
my($class, $build, $name) = @_;
my $root = $build->install_prop->{root};
Path::Tiny->new($root)->mkpath unless -d $root;
bless {
dir => Path::Tiny->new(tempdir( "${name}_XXXX", DIR => $root)),
}, $class;
}
sub as_string
{
shift->{dir}->stringify;
}
sub DESTROY
{
my($self) = @_;
if(-d $self->{dir} && $self->{dir}->children == 0)
{
rmdir($self->{dir}) || warn "unable to remove @{[ $self->{dir} ]} $!";
}
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Alien::Build - Build external dependencies for use in CPAN
=head1 VERSION
version 2.84
=head1 SYNOPSIS
my $build = Alien::Build->load('./alienfile');
$build->load_requires('configure');
$build->set_prefix('/usr/local');
$build->set_stage('/foo/mystage'); # needs to be absolute
$build->load_requires($build->install_type);
$build->download;
$build->build;
# files are now in /foo/mystage, it is your job (or
# ExtUtils::MakeMaker, Module::Build, etc) to copy
# those files into /usr/local
=head1 DESCRIPTION
This module provides tools for building external (non-CPAN) dependencies
for CPAN. It is mainly designed to be used at install time of a CPAN
client, and work closely with L