Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
perlbrew-travis-yaml.pl
#!/usr/bin/perl
#
# perlbrew-travis-yaml.pl prove [prove options]
# - runs install command
# - runs prove for each perl library
#
# perlbrew-travis-yaml.pl install
# - install all perls specified in your .travis.yml
# - create project library (".travis.yml"->parent->basename) for each perl
# - install project dependencies
#
# perlbrew-travis-yaml.pl list
# - list what is currently installed
#
# perlbrew-travis-yaml.pl clean [--all]
# - deletes project libraries
# - with --all deletes perls as well
#
# perlbrew-travis-yaml.pl dzil [dzil cmd]
# - creates perlbrew perl 'system' as an alias of system perl
# - creates library 'system@dzil'
# - installs dzil and projects its dependencies (checks every time)
# - run dzil using 'system@dzil' library
#
# WIP: exploit App::Prove and TAP::Harness to support cross-perl state, eg
# perlbrew-travis-yaml.pl list-failed
# [perl-5.10] t/test-01.t
# [perl-5.12] t/test-01.t
# [perl-5.30] t/test-02.t
# perlbrew-travis-yaml.pl prove --state failed
# will run only previously failed tests
use feature 'state';
use feature 'say';
use strict;
use warnings;
use App::Prove;
use App::perlbrew;
use Capture::Tiny qw[ capture capture_stdout ];
use Path::Tiny;
use YAML::Syck qw[];
sub perlbrew {
App::perlbrew->new (@_);
}
sub perlbrew_env {
state $perlbrew = perlbrew;
my %COPY_ENV = %ENV;
my %env = $perlbrew->perlbrew_env (@_);
$COPY_ENV{$_} = defined $env{$_} ? $env{$_} : '' for keys %env;
$COPY_ENV{PATH} = join(':', $env{PERLBREW_PATH}, $COPY_ENV{PATH});
$COPY_ENV{MANPATH} = join(':', $env{PERLBREW_MANPATH}, $COPY_ENV{MANPATH}||"");
$COPY_ENV{PERL5LIB} = $env{PERL5LIB} || "";
%COPY_ENV;
}
sub do_perlbrew {
{ local $, = ' ', say '>>>', @_ }
perlbrew (@_)->run;
}
sub do_perlbrew_exec {
{ local $, = ' ', say '>>>', 'perlbrew', @_ }
my ($with_perl, @command) = @_;
my $perlbrew = perlbrew;
$perlbrew->{quiet} = 1;
local %ENV = perlbrew_env ($with_perl);
open my $fh, '-|', @command
or die "Cannot exec @command, $!";
while (<$fh>) {
print "[$with_perl] $_";
}
close $fh;
}
sub perlbrew_perl_version {
"perl-$_[0]";
}
sub perlbrew_list {
state $perlbrew_list = {
map +( $_ => 1),
map { map $_->{name}, $_, @{ $_->{libs} } }
perlbrew->installed_perls
};
}
sub perlbrew_perl_exists {
exists perlbrew_list->{perlbrew_perl_version @_}
}
sub perlbrew_available {
state $perlbrew_available = {
reverse
map +( m/((perl-5\.\d+)\.\d+)/ ),
grep m/\bperl/,
split m/\s+/s,
capture { do_perlbrew 'available' },
};
}
sub project_root {
state $project_root = Path::Tiny::cwd;
}
sub project_name {
project_root->basename;
}
sub travis_yml {
$ENV{TRAVIS_YML} // ".travis.yml";
}
sub travis_config_file {
state $travis_config_file = do {
my $file = project_root->child (travis_yml);
die "Travis config $file not found, aborting"
unless -e $file;
$file;
};
}
sub travis_config {
state $travis_config = YAML::Syck::LoadFile (travis_config_file);
}
sub travis_perls {
@{ travis_config->{perl} };
}
sub for_installed_perls (&) {
my ($code) = @_;
$code->() for map perlbrew_perl_version ($_), travis_perls;
}
sub for_project_perls (&) {
my ($code) = @_;
$code->() for map project_libname ($_), travis_perls;
}
sub install_patchperl {
state $install_patchperl =
-f "$ENV{PERLBREW_ROOT}/bin/patchperl"
|| do_perlbrew 'install-patchperl'
;
}
sub install_travis_perls {
install_patchperl;
for my $perl_name (travis_perls) {
next if perlbrew_perl_exists $perl_name;
say "Installing perl $perl_name";
my @install_opts;
my $perl_version = $perl_name;
if ($perl_name =~ m/^(.*)-shrplib$/) {
$perl_version = $1;
@install_opts = qw[ -Duseshrplib -Duseithreads ];
}
my $perlbrew_perl_version = perlbrew_perl_version ($perl_name);
do_perlbrew 'install',
@install_opts,
'-j', 4,
'--notest',
perlbrew_available->{perlbrew_perl_version ($perl_version)},
'--as', $perlbrew_perl_version
;
system 'chmod', 'a-w', "$ENV{PERLBREW_ROOT}/perls/$perlbrew_perl_version";
}
}
sub create_system_perl {
return if exists perlbrew_list->{system};
my $path = Path::Tiny->new ($ENV{PERLBREW_ROOT}, 'perls', 'system', 'bin');
$path->mkpath unless -d $path;
my $perl = $path->child ('perl');
symlink "/usr/bin/perl", $perl unless -e $perl;
}
sub dzillib {
'system@dzil';
}
sub create_dzil {
return if exists perlbrew_list->{+dzillib};
create_system_perl;
do_perlbrew 'lib', 'create', dzillib;
}
sub project_libname {
perlbrew_perl_version (@_) . '@' . project_name;
}
sub create_project_libs {
for_project_perls {
my $lib_name = $_;
do_perlbrew lib => create => $lib_name
unless exists perlbrew_list->{$lib_name};
}
}
sub clean_project_libs {
for_project_perls {
my $lib_name = $_;
do_perlbrew lib => delete => $lib_name
if exists perlbrew_list->{$lib_name};
}
}
sub install_dependencies {
do_perlbrew_exec @_,
#'bash', '-c', 'dzil listdeps | cpanm --notest',
qw[ cpanm --quiet --installdeps --notest . ],
;
}
sub dzil_install {
state $dzil_install = capture_stdout {
do_perlbrew_exec dzillib, 'cpanm', '--quiet', '--skip-installed', 'Dist::Zilla';
};
}
sub dzil_install_authordeps {
do_perlbrew_exec dzillib, 'bash', '-c', 'dzil authordeps --missing | cpanm';
}
sub prove_arrange_overrides {
# Things that should be part of TAP::Harness and co
# See comments in subs to follow what changes
my @overrides = (
{ 'TAP::Harness' => '_get_parser_args' },
# { 'App::Prove::State::Result' => 'test' },
);
for my $override (@overrides) {
my ($class, $method) = %$override;
eval "require $class";
my $replacement = lc join '_', 'override', $class =~ s/::/_/gr, $method;
my $method_name = "${class}::${method}";
no strict 'refs';
no warnings 'redefine';
*$method_name = main->can ($replacement);
}
}
sub prove_build {
my (@args) = @_;
my $prove = My::App::Prove->new;
$prove->process_args(
@args
);
#my $state = $prove->state // [qw[ save ]];
#$prove->state ([qw[ save ]]) unless $prove->state;
$prove;
}
sub run_install {
install_travis_perls;
create_project_libs;
my $perlbrew = perlbrew;
for_project_perls {
install_dependencies $_;
}
}
sub run_prove {
my (@argv) = @_;
install_travis_perls;
create_project_libs;
my $perlbrew = perlbrew;
prove_arrange_overrides;
my $prove = prove_build ('--merge', '--color', '--formatter=TAP::Formatter::Console', @argv);
$prove->run;
}
sub run_dzil {
create_dzil;
dzil_install;
dzil_install_authordeps;
do_perlbrew_exec dzillib, 'dzil', @_;
}
sub run_clean {
clean_project_libs;
if (grep { m/^--all$/ } @_) {
for_installed_perls {
do_perlbrew uninstall => $_;
}
}
}
sub run_list {
say '>>> Travis perls';
for_installed_perls { say ' ', $_ };
say '>>> Project libraries';
for_project_perls { say ' ', $_ };
}
my %commands = (
dzil => \& run_dzil,
prove => \& run_prove,
install => \& run_install,
clean => \& run_clean,
list => \& run_list,
);
$SIG{INT} = sub { exit };
my $command = shift // 'prove';
die "Unknown command '$command', aborted"
unless exists $commands{$command};
$commands{$command}->(@ARGV);
sub override_tap_harness__get_parser_args {
# exec coderef will receive not only test program but whole job
my ( $self, $job ) = @_;
my $test_prog = $job->filename;
my %args = ();
$args{sources} = $self->sources if $self->sources;
my @switches;
@switches = $self->lib if $self->lib;
push @switches => $self->switches if $self->switches;
$args{switches} = \@switches;
$args{spool} = $self->_open_spool($test_prog);
$args{merge} = $self->merge;
$args{ignore_exit} = $self->ignore_exit;
$args{version} = $self->version if $self->version;
if ( my $exec = $self->exec ) {
$args{exec}
= ref $exec eq 'CODE'
? $exec->( $self, $test_prog, $job)
: [ @$exec, $test_prog ];
if ( not defined $args{exec} ) {
$args{source} = $test_prog;
}
elsif ( ( ref( $args{exec} ) || "" ) ne "ARRAY" ) {
$args{source} = delete $args{exec};
}
}
else {
$args{source} = $test_prog;
}
if ( defined( my $test_args = $self->test_args ) ) {
if ( ref($test_args) eq 'HASH' ) {
# different args for each test
if ( exists( $test_args->{ $job->description } ) ) {
$test_args = $test_args->{ $job->description };
}
else {
$self->_croak( "TAP::Harness Can't find test_args for "
. $job->description );
}
}
$args{test_args} = $test_args;
}
return \%args;
}
sub override_app_prove_state_result_test {
# build state test result from job info instance to be able to preserver
# job description and context as well
my ( $self, $test_info ) = @_;
# should be Ref::Util::is_plain_arrayref once it becames core module
my $name = ref ($test_info) eq 'ARRAY'
? $test_info->[0]
: $test_info
;
croak("test() requires a test name") unless defined $name;
my $tests = $self->{tests} ||= {};
if ( my $test = $tests->{$name} ) {
return $test;
}
else {
my $test = $self->test_class->new ({
name => $test_info->[1],
filename => $test_info->[0],
context => $test_info->[2],
} );
$self->{tests}->{$name} = $test;
return $test;
}
}
sub override_app_prove_state_observe_test {
# build state test result from job info instance to be able to preserver
# job description and context as well
my ( $self, $test_info, $parser ) = @_;
my $fail = scalar( $parser->failed ) + ( $parser->has_problems ? 1 : 0 );
my $todo = scalar( $parser->todo );
my $start_time = $parser->start_time;
my $end_time = $parser->end_time;
my $test = $self->results->test ($test_info);
$test->sequence( $self->{seq}++ );
$test->generation( $self->results->generation );
$test->run_time($end_time);
$test->result($fail);
$test->num_todo($todo);
$test->elapsed( $end_time - $start_time );
$test->parser($parser);
if ($fail) {
$test->total_failures( $test->total_failures + 1 );
$test->last_fail_time($end_time);
}
else {
$test->total_passes( $test->total_passes + 1 );
$test->last_pass_time($end_time);
}
}
package My::App::Prove::State;
use parent 'App::Prove::State';
sub _query_clause {
my ( $self, $clause ) = @_;
my @got;
my $results = $self->results;
my $where = $clause->{where} || sub {1};
# Select
for my $name ( $results->test_names ) {
next unless -f $name;
local $_ = $results->test($name);
push @got, $name if $where->();
}
# Sort
if ( my $order = $clause->{order} ) {
@got = map { $_->[0] }
sort {
( defined $b->[1] <=> defined $a->[1] )
|| ( ( $a->[1] || 0 ) <=> ( $b->[1] || 0 ) )
} map {
[ $_,
do { local $_ = $results->test($_); $order->() }
]
} @got;
}
if ( my $limit = $clause->{limit} ) {
@got = splice @got, 0, $limit if @got > $limit;
}
return @got;
}
package My::App::Prove;
use parent 'App::Prove';
use DDP;
sub new {
my ($class) = @_;
my $self = $class->SUPER::new;
$self->{perlbrew} = main::perlbrew;
$self;
}
sub process_args {
my $self = shift;
$self->SUPER::process_args (@_);
$self->{jobs} = 4
unless $self->{verbose};
}
sub _get_args {
my $self = shift;
my $args = $self->SUPER::_get_args (@_);
$args->{exec} = sub {
my ($harness, $filename, $job) = @_;
local *__ANON__ = '__ANON__build_perlbrew_exec_line';
my %env = $self->{perlbrew}->perlbrew_env ($job->context);
$env{PATH} = join(':', $env{PERLBREW_PATH}, $ENV{PATH});
$env{MANPATH} = join(':', $env{PERLBREW_MANPATH}, $ENV{MANPATH}||"");
$env{PERL5LIB} = $env{PERL5LIB} || "";
my @cmd = (
'/usr/bin/env',
(map +( -u => $_ ), grep ! defined $env{$_}, sort keys %env),
(map +( "$_=$env{$_}" ), grep defined $env{$_}, sort keys %env),
'perl',
$filename
);
[ @cmd ];
};
$args;
}
sub _get_tests {
my ($self) = @_;
my @tests = $self->SUPER::_get_tests;
my @all_tests;
main::for_project_perls {
my $perl_name = $_;
push @all_tests, map [ $_, "[$perl_name] $_", $perl_name ], @tests;
};
@all_tests;
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.