Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100755 398 lines (341 sloc) 12.974 kB
9523809 @masak [proof-of-concept] added
authored
1 #!/usr/local/bin/perl6
2 use v6;
3
4 use App::Pls;
5 use JSON::Tiny;
6
7 # RAKUDO: Workarounds for the core not being visible from inside roles.
8 our &_open = &open;
9 our &_slurp = &slurp;
10 our &_to-json = &to-json;
11 our &_from-json = &from-json;
12
13 role FileBackend {
14 has $.filename;
15 has Bool $!dirty;
16
17 method set-state-of($project, State $state) {
18 callsame;
19 $!dirty = True;
20 }
21
22 method save-to-file() {
23 if $!dirty {
24 _open($.filename, :w).say(_to-json(%.projects));
25 }
26 $!dirty = False;
27 }
28
29 method load-from-file() {
30 %.projects = $.filename ~~ :e ?? _from-json(_slurp($.filename))
31 !! ();
32 $!dirty = False;
33 }
34 }
35
36 class POC::ProjectsState is App::Pls::ProjectsState::Hash does FileBackend {
37 }
38
39 class POC::Ecosystem does App::Pls::Ecosystem does FileBackend {
40 has %.projects is rw;
d69966e @masak [proof-of-concept] lazily load ecosystem
authored
41 has $!loaded-projects-file = False;
9523809 @masak [proof-of-concept] added
authored
42
43 method project-info(Str $project --> Project) {
d69966e @masak [proof-of-concept] lazily load ecosystem
authored
44 # This is *so* nice!
45 unless $!loaded-projects-file++ {
46 self.load-from-file;
47 }
9523809 @masak [proof-of-concept] added
authored
48 die "No such project: $project"
49 unless %!projects.exists($project);
50 my %info = %.projects{$project};
51 %info<name> = $project;
52 return %info;
53 }
54 }
55
95955b1 @masak [proof-of-concept] better error diagnostics
authored
56 sub run-logged($command, :$step!, :$project!) {
57 my $logfile = [~] $step, '-', $project<name>, '.log';
c4c6053 @masak [proof-of-concept] write to log instead of /dev/null
authored
58 if $command ~~ /^'cd '(\S+)/ && $0 -> $subdir {
59 $logfile = '../' ~ $logfile
60 for $subdir.comb(/ ['\\/' || <-[/]> ]+ /); #'
61 }
62 my $result = run "$command > $logfile 2>&1";
63 # RAKUDO: The actual result should have a boolean value opposite that of
64 # the numeric value, but that's not so in Rakudo yet, and
65 # seemingly for two reasons: (1) &run doesn't create those
66 # integers with overloaded boolifications, and (2) even if it did
67 # something like `5 but False` evaluates to true in and 'if'
68 # statement.
69 if !$result {
affe771 @masak [proof-of-concept] unlink the right .log file
authored
70 unlink $logfile;
c4c6053 @masak [proof-of-concept] write to log instead of /dev/null
authored
71 }
72 return !$result;
97225f7 @masak [proof-of-concept] suppressed all command output
authored
73 }
74
75 sub relative-to($dir, $command) {
c4c6053 @masak [proof-of-concept] write to log instead of /dev/null
authored
76 "cd $dir && $command";
97225f7 @masak [proof-of-concept] suppressed all command output
authored
77 }
78
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored
79 sub announce-start-of(Str $action, Str $project) {
80 my $participle = "$action.ucfirst()ing";
81 my $message = $participle ~ " " x (11 - $participle.chars) ~ "$project ";
82 print $message, "." x 39 - $message.chars, ' ';
83 }
84
85 # RAKUDO: Can't type $result with Result, due to [perl #75370]
86 sub announce-end-of(Str $action, $result) {
5623bcb @masak [proof-of-concept] de-cluttered '[done]' output
authored
87 say $result == success ?? "[ done ]" !! "[ FAIL ]";
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored
88 }
89
9523809 @masak [proof-of-concept] added
authored
90 class POC::Fetcher does App::Pls::Fetcher {
91 # RAKUDO: Can't use '--> Result' after a 'where' block
92 # RAKUDO: Havn't tracked down why, but can't use a multi here to
93 # dispatch on $project<home>
94 method fetch($project) {
95 die "Not able to fetch non-github projects yet, sorry :/"
96 unless $project<home> eq 'github';
97 if "cache" !~~ :e {
95955b1 @masak [proof-of-concept] better error diagnostics
authored
98 run-logged "mkdir cache", :step('fetch'), :$project;
9523809 @masak [proof-of-concept] added
authored
99 }
100 if "cache" !~~ :d {
101 die "Cannot proceed, cache inexplicably isn't a directory";
102 }
103 my $target-dir = "cache/$project<name>";
104 if $target-dir ~~ :e {
95955b1 @masak [proof-of-concept] better error diagnostics
authored
105 run-logged "rm -rf $target-dir", :step('fetch'), :$project;
9523809 @masak [proof-of-concept] added
authored
106 }
107 my $command
108 = sprintf 'git clone git://github.com/%s/%s.git %s',
109 $project.<auth>, $project.<name>, $target-dir;
95955b1 @masak [proof-of-concept] better error diagnostics
authored
110 my $result = run-logged( $command, :step('fetch'), :$project )
111 ?? success !! failure;
9523809 @masak [proof-of-concept] added
authored
112
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored
113 return $result;
114 }
9523809 @masak [proof-of-concept] added
authored
115 }
116
117 class POC::Builder does App::Pls::Builder {
118 method build($project --> Result) {
119 my $target-dir = "cache/$project<name>";
120 if "$target-dir/Makefile" !~~ :e {
121 my $binary = 'perl6';
122
05c9d6e @masak [proof-of-concept] Makefile gets a relative PERL6LIB
authored
123 if "$target-dir/lib" !~~ :e {
9523809 @masak [proof-of-concept] added
authored
124 return success;
125 }
05c9d6e @masak [proof-of-concept] Makefile gets a relative PERL6LIB
authored
126 elsif "$target-dir/lib" !~~ :d {
9523809 @masak [proof-of-concept] added
authored
127 return failure;
128 }
129
130 # The grep is needed because 'find' prints a final newline, so
131 # there'll be an empty-string element at the end of the list.
132
133 my @module-files
134 = grep { $_ },
135 split "\n",
05c9d6e @masak [proof-of-concept] Makefile gets a relative PERL6LIB
authored
136 qqx[cd $target-dir; find lib -name \*.pm -or -name \*.pm6];
9523809 @masak [proof-of-concept] added
authored
137
138 if !@module-files || @module-files[0].lc ~~ /'no such file'/ {
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored
139 return success;
9523809 @masak [proof-of-concept] added
authored
140 }
141
142 # To know the best order of compilation, we build a dependency
143 # graph of all the modules in lib/. %usages_of ends up containing
144 # a graph, with the keys (containing names modules) being nodes,
145 # and the values (containing arrays of names) denoting directed
146 # edges.
147
148 my @modules = map { path-to-module-name($_) }, @module-files;
149 my %usages_of;
150 for @module-files -> $module-file {
663199f @masak [proof-of-concept] fixed .pm file opening
authored
151 my $fh;
152 my $succeeded = False;
153 try {
05c9d6e @masak [proof-of-concept] Makefile gets a relative PERL6LIB
authored
154 $fh = open($target-dir ~ '/' ~ $module-file, :r);
663199f @masak [proof-of-concept] fixed .pm file opening
authored
155 $succeeded = True;
156 }
157 unless $succeeded {
158 return failure;
159 }
9523809 @masak [proof-of-concept] added
authored
160 my $module = path-to-module-name($module-file);
161 %usages_of{$module} = [];
162 for $fh.lines() {
163 if /^\s* 'use' \s+ (\w+ ['::' \w+]*)/ && $0 -> $used {
164 next if $used eq 'v6';
165 next if $used eq 'MONKEY_TYPING';
166
167 %usages_of{$module}.push(~$used);
168 }
169 }
170 }
171
172 sub path-to-module-name($path) {
173 $path.subst(/^'lib/'/, '').subst(/\.pm6?$/, '')\
174 .subst('/', '::', :g);
175 }
176
177 sub module-name-to-path($module-name) {
178 my $pm = 'lib/' ~ $module-name.subst('::', '/', :g) ~ '.pm';
179 $pm ~~ :e ?? $pm !! $pm ~ '6';
180 }
181
182 my @order;
183
184 # According to "Introduction to Algorithms" by Cormen et al.,
185 # topological sort is just a depth-first search of a graph where
186 # you pay attention to the order in which you get done with the
187 # dfs-visit() for each node.
188
189 my %color_of = @modules X=> 'not yet visited';
190 for @modules -> $module {
191 if %color_of{$module} eq 'not yet visited' {
192 dfs-visit($module);
193 }
194 }
195
196 sub dfs-visit($module) {
197 %color_of{$module} = 'visited';
198 for %usages_of{$module}.list -> $used {
199 if %color_of{$used} eq 'not yet visited' {
200 dfs-visit($used);
201 }
202 }
203 push @order, $module;
204 }
205
206 # The intended effect of the below loop is to put as many module
207 # paths on each line as possible, breaking when necessary, and
208 # indenting nicely.
209
210 my @sources = map { &module-name-to-path($_) }, @order;
211 my $sources = 'SOURCES=';
212 my $line-length = 0;
213 for @sources -> $source {
214 $line-length += $source.chars + 1;
215 if $line-length > 65 {
216 # SOURCES=
217 $sources ~= "\\\n ";
218 $line-length = $source.chars + 1;
219 }
220 $sources ~= $source ~ ' ';
221 }
222 $sources.=trim-trailing;
223
05c9d6e @masak [proof-of-concept] Makefile gets a relative PERL6LIB
authored
224 my $makefile = open "$target-dir/Makefile", :w;
9523809 @masak [proof-of-concept] added
authored
225 $makefile.say(qq[PERL6=$binary]);
05c9d6e @masak [proof-of-concept] Makefile gets a relative PERL6LIB
authored
226 $makefile.say(qq[PERL6LIB='lib']);
9523809 @masak [proof-of-concept] added
authored
227 $makefile.say(q[]);
228
229 $makefile.say($sources);
230
231 $makefile.say(qq[
232 PIRS=\$(patsubst %.pm6,%.pir,\$(SOURCES:.pm=.pir))
233
234 .PHONY: test clean
235
236 all: \$(PIRS)
237
238 %.pir: %.pm
239 \tenv PERL6LIB=\$(PERL6LIB) \$(PERL6) --target=pir --output=\$@ \$<
240
241 %.pir: %.pm6
242 \tenv PERL6LIB=\$(PERL6LIB) \$(PERL6) --target=pir --output=\$@ \$<
243
244 clean:
245 \trm -f \$(PIRS)
246
247 test: all
248 \tenv PERL6LIB=\$(PERL6LIB) prove -e '\$(PERL6)' -r --nocolor t/]);
249
250 sub directory-of($file) {
251 $file.subst(/ '/' <-[/]>*? $ /, '');
252 }
253
254 sub write-install($extension?) {
255 for @sources -> $s {
256 my $file = defined $extension
257 ?? $s.subst(rx{\.pm6?$}, '.' ~ $extension)
258 !! $s;
259 # Can't use 'install -D' like we originally did,
260 # because Mac OS X has that flag as '-d'.
261 my $directory = directory-of($file);
262 $makefile.say("\tmkdir -p ~/.perl6/$directory");
263 $makefile.say("\tinstall $file ~/.perl6/$file");
264 }
265 }
266
267 $makefile.say(q[]);
268 $makefile.say(q[install: all]);
269 write-install('pir');
270
271 $makefile.say(q[]);
272 $makefile.say(q[install-src:]);
273 write-install();
de85cc4 @masak [proof-of-concept] close Makefile filehandle
authored
274
275 $makefile.close;
9523809 @masak [proof-of-concept] added
authored
276 }
95955b1 @masak [proof-of-concept] better error diagnostics
authored
277 unless run-logged( relative-to($target-dir, "make"),
278 :step('build'), :$project ) {
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored
279 return failure;
280 }
281
9523809 @masak [proof-of-concept] added
authored
282 return success;
283 }
284 }
285
286 class POC::Tester does App::Pls::Tester {
287 method test($project --> Result) {
288 my $target-dir = "cache/$project<name>";
289 if "$target-dir/Makefile" !~~ :e {
290 return failure;
291 }
95955b1 @masak [proof-of-concept] better error diagnostics
authored
292 unless run-logged( relative-to($target-dir, "make test"),
293 :step('test'), :$project ) {
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored
294 return failure;
295 }
296
9523809 @masak [proof-of-concept] added
authored
297 return success;
298 }
299 }
300
301 class POC::Installer does App::Pls::Installer {
302 method install($project --> Result) {
303 my $target-dir = "cache/$project<name>";
304 if "$target-dir/Makefile" !~~ :e {
305 return failure;
306 }
95955b1 @masak [proof-of-concept] better error diagnostics
authored
307 unless run-logged( relative-to($target-dir, "make install"),
308 :step('install'), :$project ) {
c4c6053 @masak [proof-of-concept] write to log instead of /dev/null
authored
309 return failure;
310 }
9523809 @masak [proof-of-concept] added
authored
311 return success;
312 }
313 }
314
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored
315 role POC::FetchAnnouncer {
316 method fetch($project --> Result) {
317 announce-start-of('fetch', $project<name>);
318 my $result = callsame;
319 announce-end-of('fetch', $result);
320 return $result;
321 }
322 }
323
324 role POC::BuildAnnouncer {
325 method build($project --> Result) {
326 announce-start-of('build', $project<name>);
327 my $result = callsame;
328 announce-end-of('build', $result);
329 return $result;
330 }
331 }
332
333 role POC::TestAnnouncer {
334 method test($project --> Result) {
335 announce-start-of('test', $project<name>);
336 my $result = callsame;
337 announce-end-of('test', $result);
338 return $result;
339 }
340 }
341
342 role POC::InstallAnnouncer {
343 method install($project --> Result) {
344 announce-start-of('install', $project<name>);
345 my $result = callsame;
346 announce-end-of('install', $result);
347 return $result;
348 }
349 }
350
95955b1 @masak [proof-of-concept] better error diagnostics
authored
351 sub MAIN(Str $project, Bool :$force, Bool :$skip-test) {
9523809 @masak [proof-of-concept] added
authored
352 my $projstate = POC::ProjectsState.new(:filename("poc-projects.state"));
353 $projstate.load-from-file;
354
355 my $core = App::Pls::Core.new(
356 :projects($projstate),
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored
357 :ecosystem( POC::Ecosystem.new(:filename("poc-projects.list")) ),
fbdeee6 @masak [proof-of-concept] s:4x/but/does/
authored
358 :fetcher( POC::Fetcher.new() does POC::FetchAnnouncer ),
359 :builder( POC::Builder.new() does POC::BuildAnnouncer ),
360 :tester( POC::Tester.new() does POC::TestAnnouncer ),
361 :installer( POC::Installer.new() does POC::InstallAnnouncer ),
9523809 @masak [proof-of-concept] added
authored
362 );
363
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored
364 # RAKUDO: Below line required because non-supplied named Bool
365 # comes in as Any(). [perl #73680]
95955b1 @masak [proof-of-concept] better error diagnostics
authored
366 $core.install($project, :force(?$force), :skip-test(?$skip-test));
367 say "";
368 if $core.state-of($project) eq 'installed' {
369 say "$project installed."
370 }
371 else {
372 say "===SORRY!===";
373 say "";
374 my $step = do given $core.state-of($project) {
375 when 'absent' { "fetch" }
376 when 'fetched' { "build" }
cf30ead @masak [proof-of-concept] take skip-test into account
authored
377 when 'built' { $skip-test ?? "install" !! "test" }
95955b1 @masak [proof-of-concept] better error diagnostics
authored
378 };
379 say "Couldn't install $project: the $step step failed.";
380 if $step eq "fetch" {
381 .say for "",
382 "Check to see if your internet connection is working.";
383 }
384 if $step eq "test" {
385 .say for "",
386 "This project has failing tests, which happens sometimes",
387 "for various reasons. If you want to install it despite",
388 "the failing tests, you can re-invoke $*PROGRAM_NAME",
389 "with the option '--skip-test'.";
390 }
391 .say for "",
392 "You'll find a log file `$step-$project.log` in the current",
393 "directory, with output from the failing step."
394 }
395 say "";
9523809 @masak [proof-of-concept] added
authored
396 $projstate.save-to-file();
397 }
Something went wrong with that request. Please try again.