Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Tree: f7bb51b1f8
Fetching contributors…

Cannot retrieve contributors at this time

executable file 385 lines (342 sloc) 12.726 kB
#!/usr/bin/env perl6
use v6;
use App::Pls;
use JSON::Tiny;
role FileBackend {
has $.filename;
has Bool $!dirty;
method set-state-of($project, State $state) {
callsame;
$!dirty = True;
}
method save-to-file() {
if $!dirty {
open($.filename, :w).say(to-json(%.projects));
}
$!dirty = False;
}
method load-from-file() {
%.projects = $.filename.IO ~~ :e ?? from-json(slurp($.filename))
!! ();
$!dirty = False;
}
}
class POC::ProjectsState is App::Pls::ProjectsState::Hash does FileBackend {
}
role WebBackend {
has $.url;
method load-from-url() {
my $projects = qqx[wget -q --no-check-certificate -O- $.url];
if !$projects {
die "Couldn't fetch ecosystem from the web";
}
%.projects = $projects.lines.map(
{ .[0] => { url => .[1] } given .words }
);
}
}
class POC::Ecosystem does App::Pls::Ecosystem does WebBackend {
has %.projects is rw;
has $!loaded-projects-file = False;
method project-info(Str $project --> Project) {
# This is *so* nice!
unless $!loaded-projects-file++ {
announce-start-of('load', 'ecosystem');
self.load-from-url;
announce-end-of('load', success);
}
die "No such project: $project"
unless %!projects.exists($project);
my %info = %.projects{$project};
%info<name> = $project;
return %info;
}
}
sub run-logged($command, :$step!, :$project!) {
my $logfile = [~] $step, '-', $project<name>, '.log';
if $command ~~ /^'cd '(\S+)/ && $0 -> $subdir {
$logfile = '../' ~ $logfile
for $subdir.comb(/ ['\\/' || <-[/]> ]+ /); #'
}
my $result = run "$command > $logfile 2>&1";
# RAKUDO: The actual result should have a boolean value opposite that of
# the numeric value, but that's not so in Rakudo yet, and
# seemingly for two reasons: (1) &run doesn't create those
# integers with overloaded boolifications, and (2) even if it did
# something like `5 but False` evaluates to true in and 'if'
# statement.
if !$result {
unlink $logfile;
}
return !$result;
}
sub relative-to($dir, $command) {
"cd $dir && $command";
}
sub announce-start-of(Str $action, Str $project) {
my $participle = "$action.ucfirst()ing";
my $message = $participle ~ " " x (11 - $participle.chars) ~ "$project ";
print $message, "." x 39 - $message.chars, ' ';
}
# RAKUDO: Can't type $result with Result, due to [perl #75370]
sub announce-end-of(Str $action, $result) {
say $result == success ?? "[ done ]" !! "[ FAIL ]";
}
class POC::Fetcher does App::Pls::Fetcher {
# RAKUDO: Can't use '--> Result' after a 'where' block
method fetch($project) {
if "cache".IO !~~ :e {
mkdir('cache');
}
if "cache".IO !~~ :d {
die "Cannot proceed, cache inexplicably isn't a directory";
}
my $target-dir = "cache/$project<name>";
if $target-dir.IO ~~ :e {
run-logged "rm -rf $target-dir", :step('fetch'), :$project;
}
my $command
= sprintf 'git clone %s.git %s',
$project<url>, $target-dir;
my $result = run-logged( $command, :step('fetch'), :$project )
?? success !! failure;
return $result;
}
}
sub find-files($in-dir, $pattern) {
my @files;
try { @files = dir($in-dir) }
my @found;
for @files -> $f {
next if $f eq '.' | '..';
if "$in-dir/$f".IO ~~ :d {
@found.push(find-files("$in-dir/$f", $pattern));
}
elsif $f ~~ $pattern {
@found.push("$in-dir/$f");
}
}
return @found;
}
class POC::Builder does App::Pls::Builder {
method build($project --> Result) {
my $target-dir = "cache/$project<name>";
if $*VM<config><osname> ne 'MSWin32'
&& "$target-dir/Makefile".IO ~~ :e {
# Already has Makefile and not running Windows -- use the Makefile
unless run-logged( relative-to($target-dir, 'make'),
:step('build'), :$project ) {
return failure;
}
}
else {
# No Makefile or on Windows -- roll our own `make` process
my $binary = 'perl6';
# Locate Perl 6 module files.
my @module-files = find-files("$target-dir/lib", /\.pm6?$/);
@module-files>>.=subst("$target-dir/", "");
# To know the best order of compilation, we build a dependency
# graph of all the modules in lib/. %usages_of ends up containing
# a graph, with the keys (containing names modules) being nodes,
# and the values (containing arrays of names) denoting directed
# edges.
my @modules = map { path-to-module-name($_) }, @module-files;
my %usages_of;
for @module-files -> $module-file {
my $fh;
my $succeeded = False;
try {
$fh = open($target-dir ~ '/' ~ $module-file, :r);
$succeeded = True;
}
unless $succeeded {
return failure;
}
my $module = path-to-module-name($module-file);
%usages_of{$module} = [];
for $fh.lines() {
if /^\s* 'use' \s+ (\w+ ['::' \w+]*)/ && $0 -> $used {
next if $used eq 'v6';
next if $used eq 'MONKEY_TYPING';
%usages_of{$module}.push(~$used);
}
}
}
sub path-to-module-name($path) {
$path.subst(/^'lib/'/, '').subst(/\.pm6?$/, '')\
.subst('/', '::', :g);
}
sub module-name-to-path($module-name, $base-path = '') {
my $pm = 'lib/' ~ $module-name.subst('::', '/', :g) ~ '.pm';
($base-path ~ ($base-path ?? '/' !! '') ~ $pm).IO ~~ :e
?? $pm !! $pm ~ '6';
}
my @order;
# According to "Introduction to Algorithms" by Cormen et al.,
# topological sort is just a depth-first search of a graph where
# you pay attention to the order in which you get done with the
# dfs-visit() for each node.
my %color_of = @modules X=> 'not yet visited';
for @modules -> $module {
if %color_of{$module} eq 'not yet visited' {
dfs-visit($module);
}
}
sub dfs-visit($module) {
%color_of{$module} = 'visited';
for %usages_of{$module}.list -> $used {
if %color_of{$used} eq 'not yet visited' {
dfs-visit($used);
}
}
push @order, $module;
}
for @order>>.&module-name-to-path($target-dir) -> $module {
my $command = "PERL6LIB=$target-dir/lib $binary "
~ "--target=PIR --output={
$module.subst(/\.pm6?/, ".pir")} $module";
unless run-logged( relative-to($target-dir, $command),
:step('build'), :$project ) {
return failure;
}
}
}
return success;
}
}
class POC::Tester does App::Pls::Tester {
method test($project --> Result) {
my $target-dir = "cache/$project<name>";
if $*VM<config><osname> ne 'MSWin32'
&& "$target-dir/Makefile".IO ~~ :e {
unless run-logged( relative-to($target-dir, "make test"),
:step('test'), :$project ) {
return failure;
}
}
else {
if "$target-dir/t".IO !~~ :e {
return success;
}
my $command = "env PERL6LIB=`pwd`/lib prove -e 'perl6' -r t/";
unless run-logged( relative-to($target-dir, $command),
:step('build'), :$project ) {
return failure;
}
}
return success;
}
}
class POC::Installer does App::Pls::Installer {
method install($project --> Result) {
my $target-dir = "cache/$project<name>";
if $*VM<config><osname> ne 'MSWin32'
&& "$target-dir/Makefile".IO ~~ :e {
unless run-logged( relative-to($target-dir, "make install"),
:step('install'), :$project ) {
return failure;
}
}
else {
sub mkdir-p($dir) {
if $dir ~~ / (.*) '/' / {
mkdir-p(~$0)
}
mkdir($dir)
}
for find-files("$target-dir/lib", /\.pm6?$/) -> $pmfile {
my $pirfile = $pmfile.subst(/\.pm6?$/, '.pir');
my $just-dir = $pirfile.subst(/[<-[/]>+ '/'] ** 3/, '')\
.subst(/'/' <-[/]>+ $/, '');
my $target-dir = "%*ENV<HOME>/.perl6/lib/$just-dir";
mkdir-p( $target-dir );
run( "cp $pmfile $target-dir" );
run( "cp $pirfile $target-dir" );
}
}
return success;
}
}
role POC::FetchAnnouncer {
method fetch($project --> Result) {
announce-start-of('fetch', $project<name>);
my $result = callsame;
announce-end-of('fetch', $result);
return $result;
}
}
role POC::BuildAnnouncer {
method build($project --> Result) {
announce-start-of('build', $project<name>);
my $result = callsame;
announce-end-of('build', $result);
return $result;
}
}
role POC::TestAnnouncer {
method test($project --> Result) {
announce-start-of('test', $project<name>);
my $result = callsame;
announce-end-of('test', $result);
return $result;
}
}
role POC::InstallAnnouncer {
method install($project --> Result) {
announce-start-of('install', $project<name>);
my $result = callsame;
announce-end-of('install', $result);
return $result;
}
}
sub MAIN(Str $project, Bool :$force, Bool :$skip-test) {
my $projstate = POC::ProjectsState.new(:filename("poc-projects.state"));
$projstate.load-from-file;
my $ecosystem-url
= "http://github.com/perl6/ecosystem/raw/master/projects.list";
my $core = App::Pls::Core.new(
:projects($projstate),
:ecosystem( POC::Ecosystem.new(:url($ecosystem-url)) ),
:fetcher( POC::Fetcher.new() does POC::FetchAnnouncer ),
:builder( POC::Builder.new() does POC::BuildAnnouncer ),
:tester( POC::Tester.new() does POC::TestAnnouncer ),
:installer( POC::Installer.new() does POC::InstallAnnouncer ),
);
# RAKUDO: Below line required because non-supplied named Bool
# comes in as Any(). [perl #73680]
$core.install($project, :force(?$force), :skip-test(?$skip-test));
say "";
if $core.state-of($project) eq 'installed' {
say "$project installed."
}
else {
say "===SORRY!===";
say "";
my $step = do given $core.state-of($project) {
when 'absent' { "fetch" }
when 'fetched' { "build" }
when 'built' { $skip-test ?? "install" !! "test" }
when 'tested' { "install" }
};
say "Couldn't install $project: the $step step failed.";
if $step eq "fetch" {
.say for "",
"Check to see if your internet connection is working.";
}
if $step eq "test" {
.say for "",
"This project has failing tests, which happens sometimes",
"for various reasons. If you want to install it despite",
"the failing tests, you can re-invoke $*PROGRAM_NAME",
"with the option '--skip-test'.";
}
if "$step-$project.log".IO ~~ :e {
.say for
"",
"You'll find a log file `$step-$project.log` in the current",
"directory, with output from the failing step."
}
}
say "";
$projstate.save-to-file();
}
Jump to Line
Something went wrong with that request. Please try again.