Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100755 345 lines (288 sloc) 10.696 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
97225f7 @masak [proof-of-concept] suppressed all command output
authored
56 sub run-silently($command) {
57 run "$command > /dev/null 2>&1";
58 }
59
60 sub relative-to($dir, $command) {
61 "cd $dir; $command";
62 }
63
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored
64 sub announce-start-of(Str $action, Str $project) {
65 my $participle = "$action.ucfirst()ing";
66 my $message = $participle ~ " " x (11 - $participle.chars) ~ "$project ";
67 print $message, "." x 39 - $message.chars, ' ';
68 }
69
70 # RAKUDO: Can't type $result with Result, due to [perl #75370]
71 sub announce-end-of(Str $action, $result) {
72 say $result == success ?? "[done]" !! "[FAIL]";
73 }
74
9523809 @masak [proof-of-concept] added
authored
75 class POC::Fetcher does App::Pls::Fetcher {
76 # RAKUDO: Can't use '--> Result' after a 'where' block
77 # RAKUDO: Havn't tracked down why, but can't use a multi here to
78 # dispatch on $project<home>
79 method fetch($project) {
80 die "Not able to fetch non-github projects yet, sorry :/"
81 unless $project<home> eq 'github';
82 if "cache" !~~ :e {
97225f7 @masak [proof-of-concept] suppressed all command output
authored
83 run-silently "mkdir cache";
9523809 @masak [proof-of-concept] added
authored
84 }
85 if "cache" !~~ :d {
86 die "Cannot proceed, cache inexplicably isn't a directory";
87 }
88 my $target-dir = "cache/$project<name>";
89 if $target-dir ~~ :e {
97225f7 @masak [proof-of-concept] suppressed all command output
authored
90 run-silently("rm -rf $target-dir");
9523809 @masak [proof-of-concept] added
authored
91 }
92 my $command
93 = sprintf 'git clone git://github.com/%s/%s.git %s',
94 $project.<auth>, $project.<name>, $target-dir;
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored
95 my $result = run-silently( $command ) ?? failure !! success;
9523809 @masak [proof-of-concept] added
authored
96
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored
97 return $result;
98 }
9523809 @masak [proof-of-concept] added
authored
99 }
100
101 class POC::Builder does App::Pls::Builder {
102 method build($project --> Result) {
103 my $target-dir = "cache/$project<name>";
104 if "$target-dir/Makefile" !~~ :e {
105 my $binary = 'perl6';
de85cc4 @masak [proof-of-concept] close Makefile filehandle
authored
106 my $cwd = qx[pwd].chomp ~ '/' ~ $target-dir;
9523809 @masak [proof-of-concept] added
authored
107
108 if "$cwd/lib" !~~ :e {
109 return success;
110 }
111 elsif "$cwd/lib" !~~ :d {
112 return failure;
113 }
114
115 # The grep is needed because 'find' prints a final newline, so
116 # there'll be an empty-string element at the end of the list.
117
118 my @module-files
119 = grep { $_ },
120 split "\n",
121 qqx[cd $cwd; find lib -name \*.pm -or -name \*.pm6];
122
123 if !@module-files || @module-files[0].lc ~~ /'no such file'/ {
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored
124 return success;
9523809 @masak [proof-of-concept] added
authored
125 }
126
127 # To know the best order of compilation, we build a dependency
128 # graph of all the modules in lib/. %usages_of ends up containing
129 # a graph, with the keys (containing names modules) being nodes,
130 # and the values (containing arrays of names) denoting directed
131 # edges.
132
133 my @modules = map { path-to-module-name($_) }, @module-files;
134 my %usages_of;
135 for @module-files -> $module-file {
136 my $fh = open($module-file, :r);
137 my $module = path-to-module-name($module-file);
138 %usages_of{$module} = [];
139 for $fh.lines() {
140 if /^\s* 'use' \s+ (\w+ ['::' \w+]*)/ && $0 -> $used {
141 next if $used eq 'v6';
142 next if $used eq 'MONKEY_TYPING';
143
144 %usages_of{$module}.push(~$used);
145 }
146 }
147 }
148
149 sub path-to-module-name($path) {
150 $path.subst(/^'lib/'/, '').subst(/\.pm6?$/, '')\
151 .subst('/', '::', :g);
152 }
153
154 sub module-name-to-path($module-name) {
155 my $pm = 'lib/' ~ $module-name.subst('::', '/', :g) ~ '.pm';
156 $pm ~~ :e ?? $pm !! $pm ~ '6';
157 }
158
159 my @order;
160
161 # According to "Introduction to Algorithms" by Cormen et al.,
162 # topological sort is just a depth-first search of a graph where
163 # you pay attention to the order in which you get done with the
164 # dfs-visit() for each node.
165
166 my %color_of = @modules X=> 'not yet visited';
167 for @modules -> $module {
168 if %color_of{$module} eq 'not yet visited' {
169 dfs-visit($module);
170 }
171 }
172
173 sub dfs-visit($module) {
174 %color_of{$module} = 'visited';
175 for %usages_of{$module}.list -> $used {
176 if %color_of{$used} eq 'not yet visited' {
177 dfs-visit($used);
178 }
179 }
180 push @order, $module;
181 }
182
183 # The intended effect of the below loop is to put as many module
184 # paths on each line as possible, breaking when necessary, and
185 # indenting nicely.
186
187 my @sources = map { &module-name-to-path($_) }, @order;
188 my $sources = 'SOURCES=';
189 my $line-length = 0;
190 for @sources -> $source {
191 $line-length += $source.chars + 1;
192 if $line-length > 65 {
193 # SOURCES=
194 $sources ~= "\\\n ";
195 $line-length = $source.chars + 1;
196 }
197 $sources ~= $source ~ ' ';
198 }
199 $sources.=trim-trailing;
200
201 my $makefile = open "$cwd/Makefile", :w;
202 $makefile.say(qq[PERL6=$binary]);
203 $makefile.say(qq[PERL6LIB='$cwd/lib']);
204 $makefile.say(q[]);
205
206 $makefile.say($sources);
207
208 $makefile.say(qq[
209 PIRS=\$(patsubst %.pm6,%.pir,\$(SOURCES:.pm=.pir))
210
211 .PHONY: test clean
212
213 all: \$(PIRS)
214
215 %.pir: %.pm
216 \tenv PERL6LIB=\$(PERL6LIB) \$(PERL6) --target=pir --output=\$@ \$<
217
218 %.pir: %.pm6
219 \tenv PERL6LIB=\$(PERL6LIB) \$(PERL6) --target=pir --output=\$@ \$<
220
221 clean:
222 \trm -f \$(PIRS)
223
224 test: all
225 \tenv PERL6LIB=\$(PERL6LIB) prove -e '\$(PERL6)' -r --nocolor t/]);
226
227 sub directory-of($file) {
228 $file.subst(/ '/' <-[/]>*? $ /, '');
229 }
230
231 sub write-install($extension?) {
232 for @sources -> $s {
233 my $file = defined $extension
234 ?? $s.subst(rx{\.pm6?$}, '.' ~ $extension)
235 !! $s;
236 # Can't use 'install -D' like we originally did,
237 # because Mac OS X has that flag as '-d'.
238 my $directory = directory-of($file);
239 $makefile.say("\tmkdir -p ~/.perl6/$directory");
240 $makefile.say("\tinstall $file ~/.perl6/$file");
241 }
242 }
243
244 $makefile.say(q[]);
245 $makefile.say(q[install: all]);
246 write-install('pir');
247
248 $makefile.say(q[]);
249 $makefile.say(q[install-src:]);
250 write-install();
de85cc4 @masak [proof-of-concept] close Makefile filehandle
authored
251
252 $makefile.close;
9523809 @masak [proof-of-concept] added
authored
253 }
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored
254 if run-silently( relative-to $target-dir, "make" ) {
255 return failure;
256 }
257
9523809 @masak [proof-of-concept] added
authored
258 return success;
259 }
260 }
261
262 class POC::Tester does App::Pls::Tester {
263 method test($project --> Result) {
264 my $target-dir = "cache/$project<name>";
265 if "$target-dir/Makefile" !~~ :e {
266 say "No Makefile.";
267 return failure;
268 }
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored
269 if run-silently( relative-to $target-dir, "make test" ) {
270 return failure;
271 }
272
9523809 @masak [proof-of-concept] added
authored
273 return success;
274 }
275 }
276
277 class POC::Installer does App::Pls::Installer {
278 method install($project --> Result) {
279 my $target-dir = "cache/$project<name>";
280 if "$target-dir/Makefile" !~~ :e {
281 say "No Makefile.";
282 return failure;
283 }
97225f7 @masak [proof-of-concept] suppressed all command output
authored
284 run-silently( relative-to $target-dir, "make install" )
285 and return failure;
9523809 @masak [proof-of-concept] added
authored
286 return success;
287 }
288 }
289
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored
290 role POC::FetchAnnouncer {
291 method fetch($project --> Result) {
292 announce-start-of('fetch', $project<name>);
293 my $result = callsame;
294 announce-end-of('fetch', $result);
295 return $result;
296 }
297 }
298
299 role POC::BuildAnnouncer {
300 method build($project --> Result) {
301 announce-start-of('build', $project<name>);
302 my $result = callsame;
303 announce-end-of('build', $result);
304 return $result;
305 }
306 }
307
308 role POC::TestAnnouncer {
309 method test($project --> Result) {
310 announce-start-of('test', $project<name>);
311 my $result = callsame;
312 announce-end-of('test', $result);
313 return $result;
314 }
315 }
316
317 role POC::InstallAnnouncer {
318 method install($project --> Result) {
319 announce-start-of('install', $project<name>);
320 my $result = callsame;
321 announce-end-of('install', $result);
322 return $result;
323 }
324 }
325
9523809 @masak [proof-of-concept] added
authored
326 sub MAIN(Bool :$force) {
327 my $projstate = POC::ProjectsState.new(:filename("poc-projects.state"));
328 $projstate.load-from-file;
329
330 my $core = App::Pls::Core.new(
331 :projects($projstate),
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored
332 :ecosystem( POC::Ecosystem.new(:filename("poc-projects.list")) ),
fbdeee6 @masak [proof-of-concept] s:4x/but/does/
authored
333 :fetcher( POC::Fetcher.new() does POC::FetchAnnouncer ),
334 :builder( POC::Builder.new() does POC::BuildAnnouncer ),
335 :tester( POC::Tester.new() does POC::TestAnnouncer ),
336 :installer( POC::Installer.new() does POC::InstallAnnouncer ),
9523809 @masak [proof-of-concept] added
authored
337 );
338
666d723 @masak [proof-of-concept] removed noisy output, added nice output
authored
339 # RAKUDO: Below line required because non-supplied named Bool
340 # comes in as Any(). [perl #73680]
341 my Bool $_force = ?$force;
342 $core.install("json", :force($_force));
9523809 @masak [proof-of-concept] added
authored
343 $projstate.save-to-file();
344 }
Something went wrong with that request. Please try again.