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