Skip to content

HTTPS clone URL

Subversion checkout URL

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