Current File : //proc/thread-self/root/proc/self/root/usr/local/share/perl5/Test/Alien/Build.pm
package Test::Alien::Build;
use strict;
use warnings;
use 5.008004;
use base qw( Exporter);
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.29'; # 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;
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;
}
else
{
$ok = 0;
push @diag, 'no directory';
}
}
}
else
{
$ok = 0;
push @diag, 'no alienfile';
}
my $ctx = context();
$ctx->ok($ok, $name);
$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 );
$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.29
=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<Alien::Build> and L<alienfile>. Outside of L<Alien::Build>
core development, It is probably most useful for L<Alien::Build::Plugin> developers.
This module also unsets a number of L<Alien::Build> 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<ALIEN_BUILD_PRELOAD> C<ALIEN_BUILD_POSTLOAD> C<ALIEN_INSTALL_TYPE>.
=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<alienfile>. 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<Alien::Build>
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<source> or C<filename>.
=item filename
The filename for the alienfile. You must specify one of C<source> or C<filename>.
=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<alienfile> 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<Alien::Build>. 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<share> or C<system> 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<system> or C<share>.
=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<undef> 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<undef> 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<Alien::Base> which can be passed into C<alien_ok> from L<Test::Alien>. Returns
C<undef> if the test fails.
Options
=over 4
=item class
The base class to use for your alien. This is L<Alien::Base> by default. Should
be a subclass of L<Alien::Base>, 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-E<gt>clean_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<rc.pl> 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<Alien>
=item L<alienfile>
=item L<Alien::Build>
=item L<Test::Alien>
=back
=head1 AUTHOR
Author: Graham Ollis E<lt>plicease@cpan.orgE<gt>
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 Pisar (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)
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2011-2020 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
Mini Shell