perlbrew-travis-yaml.pl

perlbrew-ci.pl

#!/usr/bin/perl
#
# perlbrew-ci.pl prove [prove options]
# - runs install command
# - runs prove for each perl library
#
# perlbrew-ci.pl install
# - install all perls specified in your .travis.yml
# - create project library (".travis.yml"->parent->basename) for each perl
# - install project dependencies
#
# perlbrew-ci.pl list
# - list what is currently installed
#
# perlbrew-ci.pl clean [--all]
# - deletes project libraries
# - with --all deletes perls as well
#
# perlbrew-ci.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
#
# TODO: 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-ci.pl prove --state failed
#   will run only previously failed tests

use v5.12; # s//r
use feature 'state';
use feature 'say';

use strict;
use warnings;

use App::Prove;
use App::perlbrew;
use Capture::Tiny qw[ capture capture_stdout ];
use Getopt::Long qw(GetOptionsFromArray);
use IPC::Run qw[ run ];
use Path::Tiny;
use Term::ANSIColor qw[ color ];
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 verbose (&) {
	return;
	$_[0]->();
}

sub do_perlbrew {
	verbose { local $, = ' ', say '>>>', @_ };
	perlbrew (@_)->run;
}

sub do_perlbrew_exec {
	verbose { 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_from_git {
	my ($stdout) = capture_stdout { run [qw[ git worktree list --porcelain ]] };
	return unless $stdout;

	my ($first_line) = split m/\n/, $stdout, 2;
	Path::Tiny->new ($first_line)->basename;

}

sub project_name_from_project_root {
	project_root->basename =~ s/@.*//r;
}

sub project_name {
	undef
		// project_name_from_git()
		// project_name_from_project_root()
		;
}

sub travis_yml {
	$ENV{TRAVIS_YML} // ".travis.yml";
}

sub travis_config_file {
	state $travis_config_file = do {
		my $file = project_root->child (travis_yml);

		return unless -e $file;

		$file;
	};
}

sub travis_config {
	state $travis_config = YAML::Syck::LoadFile (travis_config_file);
}

sub travis_perls {
	return unless travis_config_file;
	sort @{ travis_config->{perl} };
}

sub travis_perlbrew_libraries {
	map project_libname ($_), travis_perls;
}

sub github_workflows_files {
	my $dir = path (".github/workflows");

	return unless -d $dir;

	return $dir->children (qr/\.y(?:a?)ml$/);
}

sub github_workflows_find_perls {
	my ($file) = @_;

	my %perls;
	my $yaml = YAML::Syck::LoadFile ($file);

	my $jobs = $yaml->{jobs};
	for my $job (values %$jobs) {
		my $perls = $job->{strategy}{matrix}{'perl-version'} or next;
		@perls{@$perls} = @$perls;
	}

	return keys %perls;
}

sub github_workflows_perls {
	my %perls;

	for my $file (github_workflows_files) {
		my @perls = github_workflows_find_perls ($file);
		@perls{@perls} = @perls;
	}

	sort keys %perls;
}

sub ci_perls {
	for my $function (\&github_workflows_perls, \&travis_perls) {
		my @perls = grep { m/^\d+(\.\d+)*$/ } $function->();
		return @perls if @perls;
	}

	return '5.34';
}

sub project_perls {
	map project_libname ($_), ci_perls;
}

sub unused_project_libraries {
	my $match = qr/\@\Q${\ project_name }\E$/;

	my %existing;
	@existing{ grep $_ =~ $match, keys %{ perlbrew_list() } } = ();
	delete @existing{ map project_libname ($_), ci_perls };

	sort keys %existing;
}

sub for_installed_perls (&) {
	my ($code) = @_;

	$code->() for map perlbrew_perl_version ($_), ci_perls;
}

sub for_project_perls (&) {
	my ($code) = @_;

	$code->() for project_perls;
}

sub for_unused_libraries (&) {
	my ($code) = @_;

	$code->() for unused_project_libraries;
}

sub install_patchperl {
	state $install_patchperl =
		-f "$ENV{PERLBREW_ROOT}/bin/patchperl"
		|| do_perlbrew 'install-patchperl'
		;
}

sub install_ci_perls {
	install_patchperl;

	for my $perl_name (ci_perls) {
		say "Installing perl $perl_name";

		next if perlbrew_perl_exists $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', `nproc --all`,
			'--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 delete_project_lib {
	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 nop 2>/dev/null >&1 || 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 $orig = lc join '_', 'orig', $class =~ s/::/_/gr, $method;
		my $method_name = "${class}::${method}";

		no strict 'refs';
        no warnings 'redefine';
		*$orig = $class->can ($method);
		*$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_info {
	say "Project name: ", project_name;
}

sub run_install {
	install_ci_perls;
	create_project_libs;

	return unless -e "cpanfile";

	my $perlbrew = perlbrew;

	for_project_perls {
		install_dependencies $_;
	}
}

sub run_prove {
	my (@argv) = @_;

	our @DEFAULT_PROVE_ARGS = (
		'--merge',
		'--color',
		'--formatter=TAP::Formatter::Console',
		'--lib',
	);

	install_ci_perls;
	create_project_libs;

	my $perlbrew = perlbrew;

	prove_arrange_overrides;

	my $prove = prove_build (@DEFAULT_PROVE_ARGS, @argv);
	$prove->run;
}

sub run_dzil {
	create_dzil;
	dzil_install;
	dzil_install_authordeps;
	do_perlbrew_exec dzillib, 'dzil', @_;
}

sub run_clean {
	my (@argv) = @_;

	GetOptionsFromArray (
		\ @argv,
		'unused' => \ (my $clean_unused),
		'libs'   => \ (my $clean_libs),
		'all'    => \ (my $clean_perls),
	);

	$clean_libs   = 1 if $clean_perls;
	$clean_unused = 1 if $clean_libs;

	for_unused_libraries { delete_project_lib ($_) }
		if $clean_unused;

	for_project_perls { delete_project_lib ($_) }
		if $clean_libs;

	for_installed_perls { do_perlbrew uninstall => $_ }
		if $clean_perls;
}

sub run_list {
	my (@argv) = @_;

	GetOptionsFromArray (
		\ @argv,
		'show-unused|unused' => \ (my $show_unused),
	);

	#say '>>> CI perls'; for_installed_perls { say '    ', $_ };
	say '>>> Project libraries'; for_project_perls   { say '    ', $_ };

	if ($show_unused) {
		say '>>> Unused project libraries';
		for_unused_libraries { say '    ', $_ }
	}
}

sub run_newest {
	my $newest = (project_perls)[-1];
	say $newest;
}

sub run_random {
	my @perls = (project_perls);
	my $random = $perls[ int rand $#perls ];
	say $random;
}

sub run_oldest {
	my $oldest = (project_perls)[0];
	say $oldest;
}

sub run_cpanm {
	my @args = @_;

	my $perlbrew = perlbrew;

	for_project_perls {
		do_perlbrew_exec $_, qw[ cpanm --quiet --notest ], @args
	}
}

my %commands = (
	dzil  => \& run_dzil,
	prove => \& run_prove,
	install => \& run_install,
	clean => \& run_clean,
	list => \& run_list,
	info => \& run_info,
	newest => \& run_newest,
	random => \& run_random,
	oldest => \& run_oldest,
	cpanm => \& run_cpanm,
);

$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 (@_);

	Getopt::Long::GetOptionsFromArray (
		$self->{argv},
		'newest' => \$self->{use_newest},
	);

	$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',
			(map +( -I => $_), @{ $self->_get_lib // [] }),
			$filename
		);

		[ @cmd ];
	};

	$args;
}

sub _get_tests {
	my ($self) = @_;

	my @tests = $self->SUPER::_get_tests;
	my @all_tests;

	my @perls = main::project_perls;
	@perls = ($perls[1]) if $self->{use_newest};

	for my $perl_name (@perls) {
		push @all_tests, map [ $_, "[${\ ::color ('ansi4') }$perl_name${\ ::color ('reset') }] $_", $perl_name ], @tests;
	};

	@all_tests;
}