[LIB] Move last bits of Plumage-specific functionality from Util to Plumage::Util
[parrot-plumage:parrot-plumage.git] / src / plumage.nqp
1 ###
2 ### NQP WORKAROUND HACKS
3 ###
4
5
6 # Must declare all 'setting globals' here, because NQP doesn't know about them
7 my $*PROGRAM_NAME;
8 my $*OSNAME;
9 my @*ARGS;
10 my %*ENV;
11 my %*VM;
12 my $*OS;
13
14
15 # NQP does not include a setting, so must load helper libraries before
16 # even eval() will be available
17 load_helper_libraries();
18
19
20 # NQP doesn't support hash literals, so parse main structure from JSON
21 # and then fix up values that can't be represented in JSON.
22 #
23 # NOTE: 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     "projects"   : {
36         "action" : "command_projects",
37         "args"   : "none"
38     },
39     "status"   : {
40         "action" : "command_status",
41         "args"   : "opt_project"
42     },
43     "info"       : {
44         "action" : "command_info",
45         "args"   : "project"
46     },
47     "project-dir" : {
48         "action" : "command_project_dir",
49         "args"   : "project"
50     },
51     "showdeps"   : {
52         "action" : "command_showdeps",
53         "args"   : "project"
54     },
55     "fetch"      : {
56         "action" : "command_project_action",
57         "args"   : "project"
58     },
59     "update"     : {
60         "action" : "command_project_action",
61         "args"   : "project"
62     },
63     "configure"  : {
64         "action" : "command_project_action",
65         "args"   : "project"
66     },
67     "build"      : {
68         "action" : "command_project_action",
69         "args"   : "project"
70     },
71     "test"       : {
72         "action" : "command_project_action",
73         "args"   : "project"
74     },
75     "smoke"      : {
76         "action" : "command_project_action",
77         "args"   : "project"
78     },
79     "install"    : {
80         "action" : "command_project_action",
81         "args"   : "project"
82     },
83     "uninstall"  : {
84         "action" : "command_project_action",
85         "args"   : "project"
86     },
87     "clean"      : {
88         "action" : "command_project_action",
89         "args"   : "project"
90     },
91     "realclean"  : {
92         "action" : "command_project_action",
93         "args"   : "project"
94     }
95 }
96 ';
97 our %COMMANDS := fixup_commands(eval($_COMMANDS_JSON, 'data_json'));
98
99 my $_DEFAULT_CONF_JSON := '
100 {
101     "parrot_user_root"     : "#user_home_dir#/.parrot",
102     "plumage_user_root"    : "#parrot_user_root#/plumage",
103     "plumage_build_root"   : "#plumage_user_root#/build",
104     "saved_metadata_root"  : "#plumage_user_root#/saved_metadata",
105     "plumage_metadata_dir" : "metadata",
106     "installed_list_file"  : "#plumage_user_root#/installed_projects.list",
107     "root_command"         : "sudo"
108 }
109 ';
110
111 # NQP does not automatically call MAIN()
112 MAIN();
113
114
115 ###
116 ### INIT
117 ###
118
119
120 our %OPT;
121
122 my %*CONF;
123 my %*BIN;
124
125
126 sub load_helper_libraries () {
127     # Support OO
128     pir::load_bytecode('P6object.pbc');
129
130     # Utility functions and standard "globals"
131     pir::load_bytecode('src/lib/Util.pbc');
132
133     # Process command line options
134     pir::load_bytecode('Getopt/Obj.pbc');
135
136     # Parse files in JSON format
137     pir::load_bytecode('Config/JSON.pbc');
138
139     # Data structure dumper for PMCs (used for debugging)
140     pir::load_bytecode('dumper.pbc');
141
142     # Plumage modules: util, metadata, project, dependencies
143     pir::load_bytecode('src/lib/Plumage/Util.pbc');
144     pir::load_bytecode('src/lib/Plumage/Metadata.pbc');
145     pir::load_bytecode('src/lib/Plumage/Project.pbc');
146     pir::load_bytecode('src/lib/Plumage/Dependencies.pbc');
147 }
148
149 sub fixup_commands ($commands) {
150     # Convert action sub *names* into actual action subs
151     for $commands.kv -> $cmd, $opts {
152         $opts<action> := pir::get_hll_global__Ps($opts<action>);
153     }
154
155     return $commands;
156 }
157
158 sub parse_command_line_options () {
159     my $getopts := Q:PIR{ %r = root_new ['parrot';'Getopt::Obj'] };
160
161     $getopts.push_string('config-file=s');
162     $getopts.push_string('ignore-fail:%');
163
164     %OPT := $getopts.get_options(@*ARGS);
165 }
166
167 sub read_config_files () {
168     # Find config files for this system and user (ignored if missing).
169     my $etc      := %*VM<conf><sysconfdir>;
170     my $home     := user_home_dir();
171     my $base     := 'plumage.json';
172     my $sysconf  := fscat([$etc,  'parrot', 'plumage'], $base);
173     my $userconf := fscat([$home, 'parrot', 'plumage'], $base);
174     my @configs  := ($sysconf, $userconf);
175
176     # Remember home dir, we'll need that later
177     %*CONF<user_home_dir> := $home;
178
179     # If another config specified via command line option, add it.  Because
180     # this was manually set by the user, it is a fatal error if missing.
181     my $optconf  := %OPT<config-file>;
182     if $optconf {
183         if path_exists($optconf) {
184             @configs.push($optconf);
185         }
186         else {
187             pir::die("Could not find config file '$optconf'.\n");
188         }
189     }
190
191     # Merge together default, system, user, and option configs
192     my %default := eval($_DEFAULT_CONF_JSON, 'data_json');
193     %*CONF := merge_tree_structures(%*CONF, %default);
194
195     for @configs -> $config {
196         if path_exists($config) {
197             my %conf := Config::JSON::ReadConfig($config);
198             %*CONF   := merge_tree_structures(%*CONF, %conf);
199
200             CATCH {
201                 say("Could not parse JSON file '$config'.");
202             }
203         }
204     }
205
206     # _dumper(%*CONF, 'CONF');
207 }
208
209 sub merge_tree_structures ($dst, $src) {
210     for $src.keys -> $k {
211         my $d := $dst{$k};
212         my $s := $src{$k};
213
214         if  $d && pir::does__IPs($d, 'hash')
215         &&  $s && pir::does__IPs($s, 'hash') {
216             $dst{$k} := merge_tree_structures($d, $s);
217         }
218         else {
219             $dst{$k} := $s;
220         }
221     }
222
223     return $dst;
224 }
225
226 sub find_binaries () {
227     my %conf       := %*VM<config>;
228     my $parrot_bin := %conf<bindir>;
229
230     # Parrot programs; must be sourced from configured parrot bin directory
231     %*BIN<parrot_config> := fscat([$parrot_bin], 'parrot_config');
232     %*BIN<parrot-nqp>    := fscat([$parrot_bin], 'parrot-nqp');
233     %*BIN<parrot>        := fscat([$parrot_bin], 'parrot');
234
235     # Programs used to build parrot; make sure we use the same ones
236     %*BIN<perl5> := %conf<perl>;
237     %*BIN<make>  := %conf<make>;
238
239     # Unrelated system programs; look for them in the user's search path
240     %*BIN<rake>  := find_program('rake');
241     %*BIN<svn>   := find_program('svn');
242     %*BIN<git>   := find_program('git');
243     %*BIN<hg>    := find_program('hg');
244 }
245
246
247 ###
248 ### MAIN
249 ###
250
251
252 sub MAIN () {
253     parse_command_line_options();
254     read_config_files();
255     find_binaries();
256
257     my $command := parse_command_line();
258
259     execute_command($command);
260 }
261
262 sub parse_command_line () {
263     my $command := @*ARGS ?? @*ARGS.shift !! 'usage';
264
265     return $command;
266 }
267
268 sub execute_command ($command) {
269     my $action := %COMMANDS{$command}<action>;
270     my $args   := %COMMANDS{$command}<args>;
271
272     if ($action) {
273         if $args eq 'project' && !@*ARGS {
274             say('Please specify a project to act on.');
275         }
276         else {
277             $action(@*ARGS, :command($command));
278         }
279     }
280     else {
281         say("I don't know how to '$command'!");
282         pir::exit(1);
283     }
284 }
285
286
287 ###
288 ### COMMANDS
289 ###
290
291
292 sub command_usage () {
293     print(usage_info());
294 }
295
296 sub usage_info () {
297     return
298 "Usage: $*PROGRAM_NAME [<options>] <command> [<arguments>]
299
300 Options:
301
302     --config-file=<path>     Read additional config file
303
304     --ignore-fail            Ignore any failing build stages
305     --ignore-fail=<stage>    Ignore failures only in a particular stage
306                              (may be repeated to select more than one stage)
307     --ignore-fail=<stage>=0  Don't ignore failures in this stage
308
309 Commands:
310
311   Query metadata/project info:
312     projects                List all known projects
313     status      [<project>] Show status of projects (defaults to all)
314     info         <project>  Print info about a particular project
315     showdeps     <project>  Show dependency resolution for a project
316     project-dir  <project>  Print project's top directory
317
318   Perform actions on a project:
319     fetch        <project>  Download source
320     update       <project>  Update source                (falls back to fetch)
321     configure    <project>  Configure source             (updates first)
322     build        <project>  Build project from source    (configures first)
323     test         <project>  Test built project           (builds first)
324     smoke        <project>  Smoke test project           (builds first)
325     install      <project>  Install built files          (tests first)
326     uninstall    <project>  Uninstalls installed files   (not always available)
327     clean        <project>  Clean source tree
328     realclean    <project>  Clobber/realclean source tree
329
330   Get info about Plumage itself:
331     version                 Print program version and copyright
332     usage                   Print this usage info
333 ";
334 }
335
336
337 sub command_version () {
338     print(version_info());
339 }
340
341 sub version_info () {
342     my $version := '0';
343     return
344 "This is Parrot Plumage, version $version.
345
346 Copyright (C) 2009, Parrot Foundation.
347
348 This code is distributed under the terms of the Artistic License 2.0.
349 For more details, see the full text of the license in the LICENSE file
350 included in the Parrot Plumage source tree.
351 ";
352 }
353
354
355 sub command_projects () {
356     my @projects := Plumage::Metadata.get_project_list();
357        @projects.sort;
358
359     my @lengths  := map(-> $a { pir::length($a) }, @projects);
360     my $max_len  := reduce(-> $a, $b { $a >= $b ?? $a !! $b }, @lengths);
361
362     say("\nKnown projects:\n");
363
364     for @projects -> $project {
365         my $desc  := '';
366         my $meta  := Plumage::Metadata.new();
367         my $valid := $meta.find_by_project_name($project);
368
369         if $valid {
370             my %general := $meta.metadata<general>;
371             if %general {
372                 my $abstract := %general<abstract>;
373
374                 $desc := "  $abstract" if $abstract;
375             }
376         }
377
378         say(pir::sprintf__SsP("    %-{$max_len}s%s", [$project, $desc]));
379     }
380
381     say('');
382 }
383
384
385 sub command_status (@projects) {
386     my $showing_all := !@projects;
387
388     unless @projects {
389         @projects := Plumage::Metadata.get_project_list();
390         say("\nKnown projects:\n");
391     }
392
393     my @installed := Plumage::Dependencies.get_installed_projects();
394     my %installed := set_from_array(@installed);
395
396     for @projects -> $project {
397         my $status := %installed{$project} ?? 'installed' !! '-';
398         my $output := pir::sprintf__SsP("    %-30s   %s", [$project, $status]);
399         say($output);
400     }
401
402     say('') if $showing_all;
403 }
404
405
406 sub command_info (@projects) {
407     unless (@projects) {
408         say('Please include the name of the project you wish info for.');
409     }
410
411     for @projects -> $project {
412         my $meta  := Plumage::Metadata.new();
413         my $valid := $meta.find_by_project_name($project);
414
415         if $valid {
416             _dumper($meta.metadata, 'INFO');
417         }
418         else {
419             report_metadata_error($project, $meta);
420         }
421     }
422 }
423
424
425 sub command_showdeps (@projects) {
426     unless (@projects) {
427         say('Please include the name of the project to show dependencies for.');
428     }
429
430     my $unknown_project := 0;
431     for @projects -> $project {
432         my $meta  := Plumage::Metadata.new();
433         my $valid := $meta.find_by_project_name($project);
434
435         unless $valid {
436             report_metadata_error($project, $meta);
437             $unknown_project := 1;
438         }
439     }
440
441     unless $unknown_project {
442         show_dependencies(@projects);
443     }
444 }
445
446 sub report_metadata_error ($project_name, $meta) {
447     say("Metadata error for project '$project_name':\n" ~ $meta.error);
448 }
449
450
451 sub command_project_dir (@projects) {
452     unless (@projects) {
453         say('Please include the name of the project you wish to find.');
454     }
455
456     for @projects -> $project_name {
457         my $project := Plumage::Project.new($project_name);
458
459         say($project.source_dir) if pir::defined__IP($project);
460     }
461 }
462
463
464 sub command_project_action (@projects, :$command) {
465        install_required_projects(@projects)
466     && perform_actions_on_projects(@projects, :up_to($command));
467 }
468
469
470 sub install_required_projects (@projects) {
471     my %resolutions   := Plumage::Dependencies.resolve_dependencies(@projects);
472     my @need_projects := %resolutions<need_project>;
473
474     if (@need_projects) {
475         my $need_projects := pir::join(', ', @need_projects);
476         say("\nInstalling other projects to satisfy dependencies:\n"
477             ~ "    $need_projects\n");
478
479         return perform_actions_on_projects(@need_projects, :up_to('install'));
480     }
481
482     return 1;
483 }
484
485 sub show_dependencies (@projects) {
486     my %resolutions := Plumage::Dependencies.resolve_dependencies(@projects);
487
488     say('');
489
490     my $have_bin     := pir::join(' ', %resolutions<have_bin>);
491     say("Resolved by system binaries: $have_bin");
492
493     my $have_project := pir::join(' ', %resolutions<have_project>);
494     say("Resolved by Parrot projects: $have_project");
495
496     my $need_bin     := pir::join(' ', %resolutions<need_bin>);
497     say("Missing system binaries:     $need_bin");
498
499     my $need_project := pir::join(' ', %resolutions<need_project>);
500     say("Missing Parrot projects:     $need_project");
501
502     my $need_unknown := pir::join(' ', %resolutions<need_unknown>);
503     say("Missing and unrecognized:    $need_unknown");
504
505     if $need_unknown {
506         # XXXX: Don't forget to fix this when metadata is retrieved from server
507
508         say("\nI don't recognize some of these dependencies.  First, update and\n"
509             ~ "rebuild Plumage to get the latest metadata.  Next, please check\n"
510             ~ "that there are no typos in the project dependency information.\n");
511         return 0;
512     }
513     elsif $need_bin {
514         say("\nPlease use your system's package manager to install\n"
515             ~ "the missing system binaries, then restart Plumage.\n");
516         return 0;
517     }
518     elsif $need_project {
519         say("\nPlumage will install missing Parrot projects automatically.\n");
520         return 0;
521     }
522     else {
523         say("\nAll dependencies resolved.\n");
524         return 1;
525     }
526 }
527
528
529 sub perform_actions_on_projects (@projects, :$up_to, :@actions) {
530     my $has_ignore_flag := %OPT.exists('ignore-fail');
531     my %ignore          := %OPT<ignore-fail>;
532     my $ignore_all      := $has_ignore_flag && !%ignore;
533
534     for @projects -> $project_name {
535         my $project := Plumage::Project.new($project_name);
536         if pir::defined__IP($project) {
537             return 0 unless $project.perform_actions(:up_to($up_to),
538                                                      :actions(@actions),
539                                                      :ignore_all($ignore_all),
540                                                      :ignore(%ignore));
541         }
542     }
543
544     return 1;
545 }