Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
branch: pls_rstar_hacks
Fetching contributors…

Cannot retrieve contributors at this time

executable file 425 lines (365 sloc) 13.712 kB
#!/usr/bin/env perl6
use v6;
use App::Pls;
use JSON::Tiny;
# RAKUDO: Workarounds for the core not being visible from inside roles.
our &_open = &open;
our &_slurp = &slurp;
our &_to-json = &to-json;
our &_from-json = &from-json;
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 {
}
class POC::Ecosystem does App::Pls::Ecosystem does FileBackend {
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-file;
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
# RAKUDO: Havn't tracked down why, but can't use a multi here to
# dispatch on $project<home>
method fetch($project) {
die "Not able to fetch non-github projects yet, sorry :/"
unless $project<home> eq 'github';
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 && !%*ENV<PLS_NO_FETCH> {
run-logged "rm -rf $target-dir", :step('fetch'), :$project;
}
my $command
= sprintf 'git clone git://github.com/%s/%s.git %s',
$project.<auth>, $project.<name>, $target-dir;
my $result;
if %*ENV<PLS_NO_FETCH> {
$result = $target-dir.IO ~~ :d ?? success !! failure;
} else {
$result = run-logged( $command, :step('fetch'), :$project )
?? success !! failure;
}
return $result;
}
}
class POC::Builder does App::Pls::Builder {
sub find-files($in-dir, $pattern) {
my @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;
}
method build($project --> Result) {
my $target-dir = "cache/$project<name>";
if "$target-dir/Makefile".IO !~~ :e {
my $binary = 'perl6';
if "$target-dir/lib".IO !~~ :e {
return success;
}
elsif "$target-dir/lib".IO !~~ :d {
return failure;
}
# Locate Perl 6 module files.
my @module-files = find-files("$target-dir/lib", /\.pm6?$/);
if !@module-files {
return success;
}
@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.IO, :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) {
my $pm = 'lib/' ~ $module-name.subst('::', '/', :g) ~ '.pm';
$pm ~~ :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;
}
# The intended effect of the below loop is to put as many module
# paths on each line as possible, breaking when necessary, and
# indenting nicely.
my @sources = map { &module-name-to-path($_) }, @order;
my $sources = 'SOURCES=';
my $line-length = 0;
for @sources -> $source {
$line-length += $source.chars + 1;
if $line-length > 65 {
# SOURCES=
$sources ~= "\\\n ";
$line-length = $source.chars + 1;
}
$sources ~= $source ~ ' ';
}
$sources.=trim-trailing;
my $makefile = open "$target-dir/Makefile", :w;
$makefile.say(qq[PERL6=$binary]);
$makefile.say(qq[PERL6LIB='lib']);
$makefile.say(q[]);
$makefile.say($sources);
$makefile.say(qq[
PIRS=\$(patsubst %.pm6,%.pir,\$(SOURCES:.pm=.pir))
.PHONY: test clean
all: \$(PIRS)
%.pir: %.pm
\tenv PERL6LIB=\$(PERL6LIB) \$(PERL6) --target=pir --output=\$@ \$<
%.pir: %.pm6
\tenv PERL6LIB=\$(PERL6LIB) \$(PERL6) --target=pir --output=\$@ \$<
clean:
\trm -f \$(PIRS)
test: all
\tenv PERL6LIB=\$(PERL6LIB) prove -e '\$(PERL6)' -r --nocolor t/]);
sub directory-of($file) {
$file.subst(/ '/' <-[/]>*? $ /, '');
}
sub write-install($extension?) {
for @sources -> $s {
my $file = defined $extension
?? $s.subst(rx{\.pm6?$}, '.' ~ $extension)
!! $s;
# Can't use 'install -D' like we originally did,
# because Mac OS X has that flag as '-d'.
my $directory = directory-of($file);
$makefile.say("\tmkdir -p ~/.perl6/$directory");
$makefile.say("\tinstall $file ~/.perl6/$file");
}
}
$makefile.say(q[]);
$makefile.say(q[install: all]);
write-install('pir');
$makefile.say(q[]);
$makefile.say(q[install-src:]);
write-install();
$makefile.close;
}
unless run-logged( relative-to($target-dir, $*make-program),
: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 "$target-dir/Makefile".IO !~~ :e {
return failure;
}
unless run-logged( relative-to($target-dir, "$*make-program test"),
:step('test'), :$project ) {
return failure;
}
return success;
}
}
class POC::Installer does App::Pls::Installer {
method install($project --> Result) {
my $target-dir = "cache/$project<name>";
if "$target-dir/Makefile".IO !~~ :e {
return failure;
}
unless run-logged( relative-to($target-dir, "$*make-program install"),
:step('install'), :$project ) {
return failure;
}
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 determine-make-program() {
my $result = run 'nmake /? > nmake.tmp 2>&1';
unlink('nmake.tmp') if 'nmake.tmp'.IO ~~ :e;
return $result ?? 'make' !! 'nmake'
}
sub MAIN(Str $project, Bool :$force, Bool :$skip-test) {
my $projstate = POC::ProjectsState.new(:filename("poc-projects.state"));
$projstate.load-from-file;
my $*make-program = determine-make-program();
my $core = App::Pls::Core.new(
:projects($projstate),
:ecosystem( POC::Ecosystem.new(:filename("poc-projects.list")) ),
: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" }
};
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'.";
}
.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.