Skip to content
Newer
Older
100755 399 lines (342 sloc) 12.7 KB
9523809 @masak [proof-of-concept] added
authored Jun 24, 2010
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 Jul 3, 2010
41 has $!loaded-projects-file = False;
9523809 @masak [proof-of-concept] added
authored Jun 24, 2010
42
43 method project-info(Str $project --> Project) {
d69966e @masak [proof-of-concept] lazily load ecosystem
authored Jul 3, 2010
44 # This is *so* nice!
45 unless $!loaded-projects-file++ {
46 self.load-from-file;
47 }
9523809 @masak [proof-of-concept] added
authored Jun 24, 2010
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 Jul 4, 2010
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 Jul 3, 2010
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 Jul 4, 2010
70 unlink $logfile;
c4c6053 @masak [proof-of-concept] write to log instead of /dev/null
authored Jul 3, 2010
71 }
72 return !$result;
97225f7 @masak [proof-of-concept] suppressed all command output
authored Jul 3, 2010
73 }
74
75 sub relative-to($dir, $command) {
c4c6053 @masak [proof-of-concept] write to log instead of /dev/null
authored Jul 3, 2010
76 "cd $dir && $command";
97225f7 @masak [proof-of-concept] suppressed all command output
authored Jul 3, 2010
77 }
78
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored Jul 3, 2010
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) {
87 say $result == success ?? "[done]" !! "[FAIL]";
88 }
89
9523809 @masak [proof-of-concept] added
authored Jun 24, 2010
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 Jul 3, 2010
98 run-logged "mkdir cache", :step('fetch'), :$project;
9523809 @masak [proof-of-concept] added
authored Jun 24, 2010
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 Jul 3, 2010
105 run-logged "rm -rf $target-dir", :step('fetch'), :$project;
9523809 @masak [proof-of-concept] added
authored Jun 24, 2010
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 Jul 3, 2010
110 my $result = run-logged( $command, :step('fetch'), :$project )
111 ?? success !! failure;
9523809 @masak [proof-of-concept] added
authored Jun 24, 2010
112
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored Jul 3, 2010
113 return $result;
114 }
9523809 @masak [proof-of-concept] added
authored Jun 24, 2010
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';
de85cc4 @masak [proof-of-concept] close Makefile filehandle
authored Jun 24, 2010
122 my $cwd = qx[pwd].chomp ~ '/' ~ $target-dir;
9523809 @masak [proof-of-concept] added
authored Jun 24, 2010
123
124 if "$cwd/lib" !~~ :e {
125 return success;
126 }
127 elsif "$cwd/lib" !~~ :d {
128 return failure;
129 }
130
131 # The grep is needed because 'find' prints a final newline, so
132 # there'll be an empty-string element at the end of the list.
133
134 my @module-files
135 = grep { $_ },
136 split "\n",
137 qqx[cd $cwd; find lib -name \*.pm -or -name \*.pm6];
138
139 if !@module-files || @module-files[0].lc ~~ /'no such file'/ {
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored Jul 3, 2010
140 return success;
9523809 @masak [proof-of-concept] added
authored Jun 24, 2010
141 }
142
143 # To know the best order of compilation, we build a dependency
144 # graph of all the modules in lib/. %usages_of ends up containing
145 # a graph, with the keys (containing names modules) being nodes,
146 # and the values (containing arrays of names) denoting directed
147 # edges.
148
149 my @modules = map { path-to-module-name($_) }, @module-files;
150 my %usages_of;
151 for @module-files -> $module-file {
663199f @masak [proof-of-concept] fixed .pm file opening
authored Jul 4, 2010
152 my $fh;
153 my $succeeded = False;
154 try {
155 $fh = open($cwd ~ '/' ~ $module-file, :r);
156 $succeeded = True;
157 }
158 unless $succeeded {
159 return failure;
160 }
9523809 @masak [proof-of-concept] added
authored Jun 24, 2010
161 my $module = path-to-module-name($module-file);
162 %usages_of{$module} = [];
163 for $fh.lines() {
164 if /^\s* 'use' \s+ (\w+ ['::' \w+]*)/ && $0 -> $used {
165 next if $used eq 'v6';
166 next if $used eq 'MONKEY_TYPING';
167
168 %usages_of{$module}.push(~$used);
169 }
170 }
171 }
172
173 sub path-to-module-name($path) {
174 $path.subst(/^'lib/'/, '').subst(/\.pm6?$/, '')\
175 .subst('/', '::', :g);
176 }
177
178 sub module-name-to-path($module-name) {
179 my $pm = 'lib/' ~ $module-name.subst('::', '/', :g) ~ '.pm';
180 $pm ~~ :e ?? $pm !! $pm ~ '6';
181 }
182
183 my @order;
184
185 # According to "Introduction to Algorithms" by Cormen et al.,
186 # topological sort is just a depth-first search of a graph where
187 # you pay attention to the order in which you get done with the
188 # dfs-visit() for each node.
189
190 my %color_of = @modules X=> 'not yet visited';
191 for @modules -> $module {
192 if %color_of{$module} eq 'not yet visited' {
193 dfs-visit($module);
194 }
195 }
196
197 sub dfs-visit($module) {
198 %color_of{$module} = 'visited';
199 for %usages_of{$module}.list -> $used {
200 if %color_of{$used} eq 'not yet visited' {
201 dfs-visit($used);
202 }
203 }
204 push @order, $module;
205 }
206
207 # The intended effect of the below loop is to put as many module
208 # paths on each line as possible, breaking when necessary, and
209 # indenting nicely.
210
211 my @sources = map { &module-name-to-path($_) }, @order;
212 my $sources = 'SOURCES=';
213 my $line-length = 0;
214 for @sources -> $source {
215 $line-length += $source.chars + 1;
216 if $line-length > 65 {
217 # SOURCES=
218 $sources ~= "\\\n ";
219 $line-length = $source.chars + 1;
220 }
221 $sources ~= $source ~ ' ';
222 }
223 $sources.=trim-trailing;
224
225 my $makefile = open "$cwd/Makefile", :w;
226 $makefile.say(qq[PERL6=$binary]);
227 $makefile.say(qq[PERL6LIB='$cwd/lib']);
228 $makefile.say(q[]);
229
230 $makefile.say($sources);
231
232 $makefile.say(qq[
233 PIRS=\$(patsubst %.pm6,%.pir,\$(SOURCES:.pm=.pir))
234
235 .PHONY: test clean
236
237 all: \$(PIRS)
238
239 %.pir: %.pm
240 \tenv PERL6LIB=\$(PERL6LIB) \$(PERL6) --target=pir --output=\$@ \$<
241
242 %.pir: %.pm6
243 \tenv PERL6LIB=\$(PERL6LIB) \$(PERL6) --target=pir --output=\$@ \$<
244
245 clean:
246 \trm -f \$(PIRS)
247
248 test: all
249 \tenv PERL6LIB=\$(PERL6LIB) prove -e '\$(PERL6)' -r --nocolor t/]);
250
251 sub directory-of($file) {
252 $file.subst(/ '/' <-[/]>*? $ /, '');
253 }
254
255 sub write-install($extension?) {
256 for @sources -> $s {
257 my $file = defined $extension
258 ?? $s.subst(rx{\.pm6?$}, '.' ~ $extension)
259 !! $s;
260 # Can't use 'install -D' like we originally did,
261 # because Mac OS X has that flag as '-d'.
262 my $directory = directory-of($file);
263 $makefile.say("\tmkdir -p ~/.perl6/$directory");
264 $makefile.say("\tinstall $file ~/.perl6/$file");
265 }
266 }
267
268 $makefile.say(q[]);
269 $makefile.say(q[install: all]);
270 write-install('pir');
271
272 $makefile.say(q[]);
273 $makefile.say(q[install-src:]);
274 write-install();
de85cc4 @masak [proof-of-concept] close Makefile filehandle
authored Jun 24, 2010
275
276 $makefile.close;
9523809 @masak [proof-of-concept] added
authored Jun 24, 2010
277 }
95955b1 @masak [proof-of-concept] better error diagnostics
authored Jul 3, 2010
278 unless run-logged( relative-to($target-dir, "make"),
279 :step('build'), :$project ) {
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored Jul 3, 2010
280 return failure;
281 }
282
9523809 @masak [proof-of-concept] added
authored Jun 24, 2010
283 return success;
284 }
285 }
286
287 class POC::Tester does App::Pls::Tester {
288 method test($project --> Result) {
289 my $target-dir = "cache/$project<name>";
290 if "$target-dir/Makefile" !~~ :e {
291 return failure;
292 }
95955b1 @masak [proof-of-concept] better error diagnostics
authored Jul 3, 2010
293 unless run-logged( relative-to($target-dir, "make test"),
294 :step('test'), :$project ) {
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored Jul 3, 2010
295 return failure;
296 }
297
9523809 @masak [proof-of-concept] added
authored Jun 24, 2010
298 return success;
299 }
300 }
301
302 class POC::Installer does App::Pls::Installer {
303 method install($project --> Result) {
304 my $target-dir = "cache/$project<name>";
305 if "$target-dir/Makefile" !~~ :e {
306 return failure;
307 }
95955b1 @masak [proof-of-concept] better error diagnostics
authored Jul 3, 2010
308 unless run-logged( relative-to($target-dir, "make install"),
309 :step('install'), :$project ) {
c4c6053 @masak [proof-of-concept] write to log instead of /dev/null
authored Jul 3, 2010
310 return failure;
311 }
9523809 @masak [proof-of-concept] added
authored Jun 24, 2010
312 return success;
313 }
314 }
315
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored Jul 3, 2010
316 role POC::FetchAnnouncer {
317 method fetch($project --> Result) {
318 announce-start-of('fetch', $project<name>);
319 my $result = callsame;
320 announce-end-of('fetch', $result);
321 return $result;
322 }
323 }
324
325 role POC::BuildAnnouncer {
326 method build($project --> Result) {
327 announce-start-of('build', $project<name>);
328 my $result = callsame;
329 announce-end-of('build', $result);
330 return $result;
331 }
332 }
333
334 role POC::TestAnnouncer {
335 method test($project --> Result) {
336 announce-start-of('test', $project<name>);
337 my $result = callsame;
338 announce-end-of('test', $result);
339 return $result;
340 }
341 }
342
343 role POC::InstallAnnouncer {
344 method install($project --> Result) {
345 announce-start-of('install', $project<name>);
346 my $result = callsame;
347 announce-end-of('install', $result);
348 return $result;
349 }
350 }
351
95955b1 @masak [proof-of-concept] better error diagnostics
authored Jul 3, 2010
352 sub MAIN(Str $project, Bool :$force, Bool :$skip-test) {
9523809 @masak [proof-of-concept] added
authored Jun 24, 2010
353 my $projstate = POC::ProjectsState.new(:filename("poc-projects.state"));
354 $projstate.load-from-file;
355
356 my $core = App::Pls::Core.new(
357 :projects($projstate),
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored Jul 3, 2010
358 :ecosystem( POC::Ecosystem.new(:filename("poc-projects.list")) ),
fbdeee6 @masak [proof-of-concept] s:4x/but/does/
authored Jul 3, 2010
359 :fetcher( POC::Fetcher.new() does POC::FetchAnnouncer ),
360 :builder( POC::Builder.new() does POC::BuildAnnouncer ),
361 :tester( POC::Tester.new() does POC::TestAnnouncer ),
362 :installer( POC::Installer.new() does POC::InstallAnnouncer ),
9523809 @masak [proof-of-concept] added
authored Jun 24, 2010
363 );
364
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored Jul 3, 2010
365 # RAKUDO: Below line required because non-supplied named Bool
366 # comes in as Any(). [perl #73680]
95955b1 @masak [proof-of-concept] better error diagnostics
authored Jul 3, 2010
367 $core.install($project, :force(?$force), :skip-test(?$skip-test));
368 say "";
369 if $core.state-of($project) eq 'installed' {
370 say "$project installed."
371 }
372 else {
373 say "===SORRY!===";
374 say "";
375 my $step = do given $core.state-of($project) {
376 when 'absent' { "fetch" }
377 when 'fetched' { "build" }
378 when 'built' { "test" } # XXX: This will be wrong for :skip-test
379 };
380 say "Couldn't install $project: the $step step failed.";
381 if $step eq "fetch" {
382 .say for "",
383 "Check to see if your internet connection is working.";
384 }
385 if $step eq "test" {
386 .say for "",
387 "This project has failing tests, which happens sometimes",
388 "for various reasons. If you want to install it despite",
389 "the failing tests, you can re-invoke $*PROGRAM_NAME",
390 "with the option '--skip-test'.";
391 }
392 .say for "",
393 "You'll find a log file `$step-$project.log` in the current",
394 "directory, with output from the failing step."
395 }
396 say "";
9523809 @masak [proof-of-concept] added
authored Jun 24, 2010
397 $projstate.save-to-file();
398 }
Something went wrong with that request. Please try again.