[plumage] Add new configure type 'parrot_configure'
[parrot-plumage:parrot-plumage.git] / plumage.nqp
1 ###
2 ### HACKS
3 ###
4
5
6 # NQP bug XXXX: Fakecutables broken because 'nqp' language is not loaded.
7 Q:PIR{
8     $P0 = get_hll_global 'say'
9   unless null $P0 goto got_nqp
10     load_language 'nqp'
11   got_nqp:
12 };
13
14 # NQP bug XXXX: Must redeclare PIR globals because the NQP parser can't
15 #               know about variables created at load_bytecode time.
16 our $PROGRAM_NAME;
17 our @ARGS;
18 our %VM;
19
20 # NQP doesn't support array or hash literals, so parse main structure
21 # from JSON and then fix up values that can't be represented in JSON.
22 #
23 # XXXX: The data_json parser is very strict!  No extra commas, pedantic
24 #       quoting, the works.  Whitespace is perhaps your only freedom.
25 my  $_COMMANDS_JSON := '
26 {
27     "usage"      : {
28         "action" : "command_usage",
29         "args"   : "none"
30     },
31     "version"    : {
32         "action" : "command_version",
33         "args"   : "none"
34     },
35     "info"       : {
36         "action" : "command_info",
37         "args"   : "project"
38     },
39     "fetch"      : {
40         "action" : "command_fetch",
41         "args"   : "project"
42     },
43     "configure"  : {
44         "action" : "command_configure",
45         "args"   : "project"
46     },
47     "build"      : {
48         "action" : "command_build",
49         "args"   : "project"
50     },
51     "test"       : {
52         "action" : "command_test",
53         "args"   : "project"
54     },
55     "install"    : {
56         "action" : "command_install",
57         "args"   : "project"
58     }
59 }
60 ';
61 our %COMMANDS := fixup_commands(eval($_COMMANDS_JSON, 'data_json'));
62
63 my  $_ACTIONS_JSON := '
64 {
65     "fetch"     : [ "git", "svn" ],
66     "configure" : [ "perl5_configure", "parrot_configure" ],
67     "build"     : [ "make" ],
68     "test"      : [ "make" ],
69     "install"   : [ "make" ]
70 }
71 ';
72 our %ACTION;
73 load_helper_libraries();
74 fixup_sub_actions(eval($_ACTIONS_JSON, 'data_json'));
75
76 # NQP does not automatically call MAIN()
77 MAIN();
78
79
80 ###
81 ### INIT
82 ###
83
84
85 our %STAGE_ACTION;
86 our %STAGES;
87 our %BIN;
88
89 sub load_helper_libraries () {
90     # Globals, common functions, system access, etc.
91     load_bytecode('Glue.pir');
92
93     # Data structure dumper for PMCs (used for debugging)
94     load_bytecode('dumper.pbc');
95 }
96
97 sub fixup_commands ($commands) {
98     # Convert action sub *names* into actual action subs
99     Q:PIR{
100         $P0 = find_lex '$commands'
101         $P1 = iter $P0
102       fixup_loop:
103         unless $P1 goto fixup_loop_end
104         $S0 = shift $P1
105         $P2 = $P1[$S0]
106         $S1 = $P2['action']
107         $P3 = get_hll_global $S1
108         $P2['action'] = $P3
109         goto fixup_loop
110       fixup_loop_end:
111     };
112
113     return $commands;
114 }
115
116 sub fixup_sub_actions (%actions) {
117     my @stages := keys(%actions);
118
119     for @stages {
120         my $stage   := $_;
121         my @actions := %actions{$stage};
122
123         for @actions {
124             my $sub_name := $stage ~ '_' ~ $_;
125             my $sub      := Q:PIR {
126                 $P0 = find_lex '$sub_name'
127                 $S0 = $P0
128                 %r  = get_hll_global $S0
129             };
130
131             if $sub {
132                 %ACTION{$stage}{$_} := $sub;
133             }
134             else {
135                 die("Action sub '" ~ $sub_name ~ "' is missing!\n");
136             }
137         }
138     }
139 }
140
141 sub find_binaries () {
142     my %conf       := %VM<config>;
143     my $parrot_bin := %conf<bindir>;
144
145     %BIN<parrot_config> := fscat($parrot_bin, 'parrot_config');
146 }
147
148 sub build_stages () {
149     my @stages := split(' ', 'install test build configure fetch');
150
151     for @stages {
152         my $stage       := $_;
153
154         %STAGES{$stage} := split(' ', '');
155
156         for keys(%STAGES) {
157             %STAGES{$_}.unshift($stage);
158         }
159
160         my $sub_name := 'action_' ~ $stage;
161         my $sub      := Q:PIR {
162             $P0 = find_lex '$sub_name'
163             $S0 = $P0
164             %r  = get_hll_global $S0
165         };
166         %STAGE_ACTION{$stage} := $sub;
167     }
168 }
169
170
171 ###
172 ### MAIN
173 ###
174
175
176 sub MAIN () {
177     find_binaries();
178     build_stages();
179
180     my $command := parse_command_line();
181
182     execute_command($command);
183 }
184
185 sub parse_command_line () {
186     my $command := 'usage';
187
188     if (@ARGS) {
189         $command := @ARGS.shift;
190     }
191
192     return $command;
193 }
194
195 sub execute_command ($command) {
196     my $action := %COMMANDS{$command}<action>;
197     my $args   := %COMMANDS{$command}<args>;
198
199     if ($action) {
200         if $args eq 'project' && !@ARGS {
201             say('Please include the name of the project you wish info for.');
202         }
203         else {
204             $action(@ARGS);
205         }
206     }
207     else {
208         say("I don't know how to '" ~ $command ~ "'!");
209     }
210 }
211
212
213 ###
214 ### COMMANDS
215 ###
216
217
218 sub command_usage () {
219     print(usage_info());
220 }
221
222 sub usage_info () {
223     return
224 'Usage: ' ~ $PROGRAM_NAME ~ ' [<options>] <command> [<arguments>]
225
226 Available commands:
227
228     info      <project>  Print info about a particular project
229     fetch     <project>  Download source for a project
230     configure <project>  Configure source for project (fetches first)
231     build     <project>  Build project from source (configures first)
232     test      <project>  Test built project (builds first)
233     install   <project>  Installs built project files (tests first)
234
235     version              Print program version and copyright
236     usage                Print this usage info
237 ';
238 }
239
240
241 sub command_version () {
242     print(version_info());
243 }
244
245 sub version_info () {
246     my $version := '0';
247     return
248 'This is Parrot Plumage, version ' ~ $version ~ '.
249
250 Copyright (C) 2009, Parrot Foundation.
251
252 This code is distributed under the terms of the Artistic License 2.0.
253 For more details, see the full text of the license in the LICENSE file
254 included in the Parrot Plumage source tree.
255 ';
256 }
257
258
259 sub command_info (@projects) {
260     unless (@projects) {
261         say('Please include the name of the project you wish info for.');
262     }
263
264     for @projects {
265         my $info := get_project_metadata($_);
266
267         _dumper($info, 'INFO');
268     }
269 }
270
271 sub get_project_metadata ($project) {
272     load_bytecode('Config/JSON.pbc');
273
274     return Config::JSON::ReadConfig('metadata/' ~ $project ~ '.json');
275 }
276
277 sub metadata_valid (%info) {
278     my %spec          := %info<meta-spec>;
279     my $known_uri     := 'https://trac.parrot.org/parrot/wiki/ModuleEcosystem';
280     my $known_version := 1;
281
282     unless %spec && %spec<uri> {
283         say("I don't understand this project's metadata at all.");
284         return 0;
285     }
286
287     unless %spec<uri> eq $known_uri {
288         say("This project's metadata specifies unknown metadata spec URI '"
289             ~ %spec<uri> ~ "'.");
290         return 0;
291     }
292
293     if    %spec<version> == $known_version {
294         return 1;
295     }
296     elsif %spec<version>  > $known_version {
297         say("This project's metadata is too new to parse; it is version "
298             ~ %spec<version> ~ " and I only understand version "
299             ~ $known_version ~ ".");
300     }
301     else {
302         say("This project's metadata is too old to parse; it is version "
303             ~ %spec<version> ~ " and I only understand version "
304             ~ $known_version ~ ".");
305     }
306
307     return 0;
308 }
309
310
311 sub command_fetch (@projects) {
312     perform_actions_on_projects(%STAGES<fetch>, @projects);
313 }
314
315 sub command_configure (@projects) {
316     perform_actions_on_projects(%STAGES<configure>, @projects);
317 }
318
319 sub command_build (@projects) {
320     perform_actions_on_projects(%STAGES<build>, @projects);
321 }
322
323 sub command_test (@projects) {
324     perform_actions_on_projects(%STAGES<test>, @projects);
325 }
326
327 sub command_install (@projects) {
328     perform_actions_on_projects(%STAGES<install>, @projects);
329 }
330
331
332 sub perform_actions_on_projects (@actions, @projects) {
333     for @projects {
334         my %info := get_project_metadata($_);
335         if %info {
336             if metadata_valid(%info) {
337                 perform_actions_on_project(@actions, $_, %info);
338             }
339         }
340         else {
341             say("I don't know anything about project '" ~ $_ ~ "'.");
342         }
343     }
344 }
345
346 sub perform_actions_on_project (@actions, $project, %info) {
347     for @actions {
348         my &action := %STAGE_ACTION{$_};
349
350         if &action {
351            my $result := &action($project, %info);
352            if $result {
353                say('Successful.');
354            }
355            else {
356                say("###\n### FAILED!\n###");
357                return 0;
358            }
359         }
360         else {
361            say("I don't know how to perfom action '" ~ $_ ~ "'.");
362         }
363     }
364
365     return 1;
366 }
367
368
369 ###
370 ### ACTIONS
371 ###
372
373
374 # FETCH
375
376 sub action_fetch ($project, %info) {
377     my %repo := %info<resources><repository>;
378     if %repo {
379         say("Fetching " ~ $project ~ ' ...');
380
381         my &action := %ACTION<fetch>{%repo<type>};
382         return &action($project, %repo<checkout_uri>);
383     }
384     else {
385         say("Don't know how to fetch " ~ project ~ ".");
386         return 0;
387     }
388 }
389
390 sub fetch_git ($project, $uri) {
391     return check_run_success(run('git', 'clone', $uri, $project));
392 }
393 sub fetch_svn ($project, $uri) {
394     return check_run_success(run('svn', 'checkout', $uri, $project));
395 }
396
397
398 # CONFIGURE
399
400 sub action_configure ($project, %info) {
401     my %conf := %info<instructions><configure>;
402     if %conf {
403         say("\nConfiguring " ~ $project ~ ' ...');
404
405         my &action := %ACTION<configure>{%conf<type>};
406         return &action($project, %conf);
407     }
408     else {
409         say("\nConfiguration not required for " ~ $project ~ ".");
410         return 1;
411     }
412 }
413
414 sub configure_perl5_configure ($project, %conf) {
415     my $cwd := cwd();
416     chdir($project);
417
418     my $perl5   := %VM<config><perl>;
419     my $success := check_run_success(run($perl5, 'Configure.pl'));
420
421     chdir($cwd);
422
423     return $success;
424 }
425
426 sub configure_parrot_configure ($project, %conf) {
427     my $cwd := cwd();
428     chdir($project);
429
430     my $parrot  := fscat(%VM<config><bindir>, 'parrot');
431     my $success := check_run_success(run($parrot, 'Configure.pir'));
432
433     chdir($cwd);
434
435     return $success;
436 }
437
438
439 # MAKE
440
441 sub action_build ($project, %info) {
442     my %conf := %info<instructions><build>;
443     if %conf {
444         say("\nBuilding " ~ $project ~ ' ...');
445
446         my &action := %ACTION<build>{%conf<type>};
447         return &action($project);
448     }
449     else {
450         say("\nBuild not required for " ~ $project ~ ".");
451         return 1;
452     }
453 }
454
455 sub build_make ($project) {
456     my $cwd := cwd();
457     chdir($project);
458
459     my $make    := %VM<config><make>;
460     my $success := check_run_success(run($make));
461
462     chdir($cwd);
463
464     return $success;
465 }
466
467
468 # TEST
469
470 sub action_test ($project, %info) {
471     my %conf := %info<instructions><test>;
472     if %conf {
473         say("\nTesting " ~ $project ~ ' ...');
474
475         my &action := %ACTION<test>{%conf<type>};
476         return &action($project);
477     }
478     else {
479         say("\nNo test method found for " ~ $project ~ ".");
480         return 1;
481     }
482 }
483
484 sub test_make ($project) {
485     my $cwd := cwd();
486     chdir($project);
487
488     my $make := %VM<config><make>;
489     my $success := check_run_success(run($make, 'test'));
490
491     chdir($cwd);
492
493     return $success;
494 }
495
496
497 # INSTALL
498
499 sub action_install ($project, %info) {
500     my %conf := %info<instructions><install>;
501     if %conf {
502         say("\nInstalling " ~ $project ~ ' ...');
503
504         my &action := %ACTION<install>{%conf<type>};
505         return &action($project);
506     }
507     else {
508         say("Don't know how to install " ~ project ~ ".");
509         return 0;
510     }
511 }
512
513 sub install_make ($project) {
514     my $cwd := cwd();
515     chdir($project);
516
517     my $make := %VM<config><make>;
518     my $success := check_run_success(run($make, 'install'));
519
520     chdir($cwd);
521
522     return $success;
523 }
524
525
526 ###
527 ### UTILS
528 ###
529
530
531 sub check_run_success ($exit_val) {
532     return $exit_val ?? 0 !! 1;
533 }
534
535
536 sub replace_config_strings ($original) {
537     return subst($original, '\#<ident>\#', config_value);
538 }
539
540 sub config_value ($match) {
541     my $key    := $match<ident>;
542     my $config := %VM<config>{$key} || %BIN{$key} || '';
543
544     return $config;
545 }