Convert to native NQP-rx regex; move last bits of Glue functionality to Util; kill...
[parrot-plumage:parrot-plumage.git] / src / lib / Plumage / Project.nqp
1 =begin
2
3 =head1 NAME
4
5 Plumage::Project - A project, its metadata, and its state
6
7 =head1 SYNOPSIS
8
9     # Load this library
10     pir::load_bytecode('src/lib/Plumage/Project.pbc');
11
12     # Instantiate a project, given name, metadata file, directory, or 'this'
13     my $project := Plumage::Project.new('foo');       # By name
14     my $project := Plumage::Project.new('foo.json');  # By metadata
15     my $project := Plumage::Project.new('git/foo');   # By specific directory
16     my $project := Plumage::Project.new('this');      # By current directory
17
18     # Get list of valid actions
19     my @actions := Plumage::Project.known_actions;
20
21     # Perform multiple actions on a project in sequence, stopping on failure
22     $project.perform_actions(:$up_to, :@actions, :$ignore_all, :%ignore);
23
24     # Perform individual actions on a project
25     $project.fetch;
26     $project.update;
27     $project.configure;
28     $project.build;
29     $project.test;
30     $project.smoke;
31     $project.install;
32     $project.uninstall;
33     $project.clean;
34     $project.realclean;
35
36
37 =head1 DESCRIPTION
38
39 =end
40
41 class Plumage::Project;
42
43 has $!name;
44 has $!metadata;
45 has $!source_dir;
46
47 method name       () { $!name       }
48 method metadata   () { $!metadata   }
49 method source_dir () { $!source_dir }
50
51
52 # CONSTRUCTION
53
54 method new($locator) {
55     my $class := pir::getattribute__PPs(self.HOW, 'parrotclass');
56     Q:PIR{ $P0  = find_lex '$class'
57            self = new $P0           };
58
59     return self._init($locator);
60 }
61
62
63 method _init($locator) {
64     $!metadata     := Plumage::Metadata.new;
65     my $build_root := replace_config_strings(%*CONF<plumage_build_root>);
66     my $undef;
67
68     if $locator eq 'this' {
69         $!source_dir := self._find_source_dir();
70         $!metadata.load_from_project_dir($!source_dir);
71     }
72     elsif is_dir($locator) {
73         $!source_dir := self._find_source_dir($locator);
74         $!metadata.load_from_project_dir($!source_dir);
75     }
76     elsif pir::length($locator) > 5
77        && pir::substr($locator, -5, 5) eq '.json' {
78         $!metadata.load_from_file($locator);
79
80         my $file_dir := subst($locator, /<-[\/]>+$/, '');
81         $!source_dir := self._find_source_dir($file_dir);
82     }
83     elsif $!metadata.find_by_project_name($locator) {
84         $!source_dir := fscat([$build_root], $locator);
85     }
86
87     unless $!metadata.is_valid {
88         say($!metadata.error);
89         return $undef;
90     }
91
92     $!name       := $!metadata.metadata<general><name>;
93     $!source_dir := fscat([$build_root], $!name)
94                     unless pir::length($!source_dir);
95
96     return self;
97 }
98
99
100 method _find_source_dir($start_dir?) {
101     my $orig_dir := $*OS.cwd;
102
103     $*OS.chdir($start_dir) if pir::length($start_dir);
104
105     my $old_dir  := '';
106
107     until $old_dir eq $*OS.cwd || $!metadata.exists {
108         $old_dir := $*OS.cwd;
109         $*OS.chdir('..');
110     }
111
112     my $source_dir := $!metadata.exists ?? $*OS.cwd !! '';
113
114     $*OS.chdir($orig_dir);
115
116     return $source_dir;
117 }
118
119
120 ###
121 ### ACTIONS
122 ###
123
124 method known_actions () {
125     return grep(-> $_ {self.HOW.can(self, $_)},
126                 < fetch update configure build test smoke
127                   install uninstall clean realclean >);
128 }
129
130 sub _build_stage_paths () {
131     our %STAGES;
132
133     # All stages in install path require their predecessors
134     my  @install_path := pir::split(' ', 'install test build configure update');
135     for @install_path -> $stage {
136         %STAGES{$stage} := [];
137
138         for %STAGES {
139             $_.value.unshift($stage);
140         }
141     }
142
143     # Smoke test requires same path as regular test
144     %STAGES<smoke> := %STAGES<test>;
145 }
146
147 method _actions_up_to ($stage) {
148     our %STAGES;
149     _build_stage_paths();
150
151     return %STAGES{$stage};
152 }
153
154 method perform_actions (:$up_to, :@actions, :$ignore_all, :%ignore) {
155     if $up_to && @actions {
156         die("Cannot specify both up_to and actions in perform_actions()");
157     }
158     elsif $up_to {
159         @actions := self._actions_up_to($up_to) || [$up_to];
160     }
161
162     my %valid := set_from_array(self.known_actions);
163
164     for @actions -> $action {
165         if %valid{$action} {
166            my $cwd    := $*OS.cwd;
167            my $result := self."$action"();
168            $*OS.chdir($cwd);
169
170            if $result {
171                say("Successful.\n");
172            }
173            else {
174                if $ignore_all || %ignore && %ignore{$action} {
175                    say("FAILED, but ignoring failure at user request.\n");
176                }
177                else {
178                    say("###\n### FAILED!\n###\n");
179                    return 0;
180                }
181            }
182         }
183         else {
184            say("I don't know how to perfom action '$action'.");
185            return 0;
186         }
187     }
188
189     return 1;
190 }
191
192
193 # FETCH
194
195 method fetch () {
196     my %fetch := $!metadata.metadata<instructions><fetch>;
197     if %fetch {
198         my $build_root := replace_config_strings(%*CONF<plumage_build_root>);
199
200         mkpath($build_root) if !is_dir($build_root)
201                             && pir::index($!source_dir, $build_root) == 0;
202
203         return self."fetch_{%fetch<type>}"();
204     }
205     else {
206         say("Don't know how to fetch $!name.");
207         return 0;
208     }
209 }
210
211 method fetch_repository () {
212     my %repo := $!metadata.metadata<resources><repository>;
213     if %repo {
214         say("Fetching $!name ...");
215
216         return self."fetch_{%repo<type>}"();
217     }
218     else {
219         say("Trying to fetch from a repository, but no repository info for $!name.");
220         return 0;
221     }
222 }
223
224 method fetch_git () {
225     if path_exists($!source_dir) {
226         if path_exists(fscat([$!source_dir, '.git'])) {
227             $*OS.chdir($!source_dir);
228             return do_run(%*BIN<git>, 'pull')
229                 && do_run(%*BIN<git>, 'submodule', 'update', '--init');
230         }
231         else {
232             return self.report_fetch_collision('Git');
233         }
234     }
235     else {
236         my $uri := $!metadata.metadata<resources><repository><checkout_uri>;
237
238         return 0 unless do_run(%*BIN<git>, 'clone', $uri, $!source_dir);
239
240         $*OS.chdir($!source_dir);
241         return do_run(%*BIN<git>, 'submodule', 'update', '--init');
242     }
243 }
244
245 method fetch_hg () {
246     if path_exists($!source_dir) {
247         if path_exists(fscat([$!source_dir, '.hg'])) {
248             $*OS.chdir($!source_dir);
249             return do_run(%*BIN<hg>, 'pull', '-u');
250         }
251         else {
252             return self.report_fetch_collision('Mercurial');
253         }
254     }
255     else {
256         my $uri := $!metadata.metadata<resources><repository><checkout_uri>;
257
258         return do_run(%*BIN<hg>, 'clone', $uri, $!source_dir);
259     }
260 }
261
262 method fetch_svn () {
263     if  path_exists($!source_dir)
264     && !path_exists(fscat([$!source_dir, '.svn'])) {
265         return report_fetch_collision('Subversion');
266     }
267     else {
268         my $uri := $!metadata.metadata<resources><repository><checkout_uri>;
269
270         return do_run(%*BIN<svn>, 'checkout', $uri, $!source_dir);
271     }
272 }
273
274 method report_fetch_collision ($type) {
275     say("\n$!name is a $type project, but the fetch directory:\n"
276         ~ "\n    $!source_dir\n\n"
277         ~ "already exists and is not the right type.\n"
278         ~ "Please remove or rename it, then rerun $*PROGRAM_NAME.\n");
279
280     return 0;
281 }
282
283
284 # UPDATE
285
286 method update () {
287     my %update := $!metadata.metadata<instructions><update>;
288
289     if %update && path_exists($!source_dir) {
290         return self."update_{%update<type>}"();
291     }
292     else {
293         # Fall back to standard FETCH semantics
294         return self.fetch;
295     }
296 }
297
298 method update_repository () {
299     my %repo := $!metadata.metadata<resources><repository>;
300     if %repo {
301         say("Updating $!name ...");
302
303         # Reuse existing FETCH logic
304         return self."fetch_{%repo<type>}"();
305     }
306     else {
307         say("Trying to update from a repository, but no repository info for $!name.");
308         return 0;
309     }
310 }
311
312 method update_parrot_setup () {
313     $*OS.chdir($!source_dir);
314
315     return do_run(%*BIN<parrot>, 'setup.pir', 'update');
316 }
317
318
319 # CONFIGURE
320
321 method configure () {
322     my %conf := $!metadata.metadata<instructions><configure>;
323     if %conf {
324         say("\nConfiguring $!name ...");
325
326         $*OS.chdir($!source_dir);
327
328         return self."configure_{%conf<type>}"();
329     }
330     else {
331         say("\nConfiguration not required for $!name.");
332         return 1;
333     }
334 }
335
336 method configure_rake () {
337     return do_run(%*BIN<rake>, 'config');
338 }
339
340 method configure_perl5_configure () {
341     my $extra := $!metadata.metadata<instructions><configure><extra_args>;
342     my @extra := map(replace_config_strings, $extra);
343
344     return do_run(%*BIN<perl5>, 'Configure.pl', |@extra);
345 }
346
347 method configure_parrot_configure () {
348     return do_run(%*BIN<parrot>, 'Configure.pir');
349 }
350
351 method configure_nqp_configure () {
352     return do_run(%*BIN<parrot-nqp>, 'Configure.nqp');
353 }
354
355
356 # BUILD
357
358 method build () {
359     my %build := $!metadata.metadata<instructions><build>;
360     if %build {
361         say("\nBuilding $!name ...");
362
363         $*OS.chdir($!source_dir);
364
365         return self."build_{%build<type>}"();
366     }
367     else {
368         say("\nBuild not required for $!name.");
369         return 1;
370     }
371 }
372
373 method build_make () {
374     return do_run(%*BIN<make>);
375 }
376
377 method build_rake () {
378     return do_run(%*BIN<rake>);
379 }
380
381 method build_parrot_setup () {
382     return do_run(%*BIN<parrot>, 'setup.pir');
383 }
384
385
386 # TEST
387
388 method test () {
389     my %test := $!metadata.metadata<instructions><test>;
390     if %test {
391         say("\nTesting $!name ...");
392
393         $*OS.chdir($!source_dir);
394
395         return self."test_{%test<type>}"();
396     }
397     else {
398         say("\nNo test method found for $!name.");
399         return 1;
400     }
401 }
402
403 method test_make () {
404     return do_run(%*BIN<make>, 'test');
405 }
406
407 method test_rake () {
408     return do_run(%*BIN<rake>, 'test');
409 }
410
411 method test_parrot_setup () {
412     return do_run(%*BIN<parrot>, 'setup.pir', 'test');
413 }
414
415
416 # SMOKE
417
418 method smoke () {
419     my %smoke := $!metadata.metadata<instructions><smoke>;
420     if %smoke {
421         say("\nSmoke testing $!name ...");
422
423         $*OS.chdir($!source_dir);
424
425         return self."smoke_{%smoke<type>}"();
426     }
427     else {
428         say("\nNo smoke test method found for $!name.");
429         return 1;
430     }
431 }
432
433 method smoke_make () {
434     return do_run(%*BIN<make>, 'smoke');
435 }
436
437 method smoke_parrot_setup () {
438     return do_run(%*BIN<parrot>, 'setup.pir', 'smoke');
439 }
440
441
442 # INSTALL
443
444 method install () {
445     my %inst := $!metadata.metadata<instructions><install>;
446     if %inst {
447         say("\nInstalling $!name ...");
448
449         $*OS.chdir($!source_dir);
450
451         my $success := self."install_{%inst<type>}"();
452
453         if $success {
454             $!metadata.save_install_copy;
455             Plumage::Dependencies.mark_projects_installed([$!name]);
456         }
457
458         return $success;
459     }
460     else {
461         say("Don't know how to install $!name.");
462         return 0;
463     }
464 }
465
466 method install_make () {
467     return self.do_with_privs(%*BIN<make>, 'install');
468 }
469
470 method install_rake () {
471     return self.do_with_privs(%*BIN<rake>, 'install');
472 }
473
474 method install_parrot_setup () {
475     return self.do_with_privs(%*BIN<parrot>, 'setup.pir', 'install');
476 }
477
478
479 # UNINSTALL
480
481 method uninstall () {
482     my %uninst := $!metadata.metadata<instructions><uninstall>;
483     if %uninst {
484         say("\nUninstalling $!name ...");
485
486         $*OS.chdir($!source_dir);
487
488         my $success := self."uninstall_{%uninst<type>}"();
489
490         if $success {
491             $!metadata.remove_install_copy;
492             Plumage::Dependencies.mark_projects_uninstalled([$!name]);
493         }
494
495         return $success;
496     }
497     else {
498         say("Don't know how to uninstall $!name.");
499         return 0;
500     }
501 }
502
503 method uninstall_parrot_setup () {
504     return self.do_with_privs(%*BIN<parrot>, 'setup.pir', 'uninstall');
505 }
506
507 method do_with_privs (*@cmd) {
508     my $bin_dir  := %*VM<config><bindir>;
509     my $root_cmd := replace_config_strings(%*CONF<root_command>);
510
511     if !test_dir_writable($bin_dir) && $root_cmd {
512         return do_run($root_cmd, |@cmd);
513     }
514     else {
515         return do_run(|@cmd);
516     }
517 }
518
519
520 # CLEAN
521
522 method clean () {
523     unless path_exists($!source_dir) {
524         say("\nProject source dir '$!source_dir' does not exist; nothing to do.");
525         return 1;
526     }
527
528     my %clean := $!metadata.metadata<instructions><clean>;
529     if %clean {
530         say("\nCleaning $!name ...");
531
532         $*OS.chdir($!source_dir);
533
534         return self."clean_{%clean<type>}"();
535     }
536     else {
537         say("\nNo clean method found for $!name.");
538         return 1;
539     }
540 }
541
542 method clean_make () {
543     return do_run(%*BIN<make>, 'clean');
544 }
545
546 method clean_rake () {
547     return do_run(%*BIN<rake>, 'clean');
548 }
549
550 method clean_parrot_setup () {
551     return do_run(%*BIN<parrot>, 'setup.pir', 'clean');
552 }
553
554
555
556 # REALCLEAN
557
558 method realclean () {
559     unless path_exists($!source_dir) {
560         say("\nProject source dir '$!source_dir' does not exist; nothing to do.");
561         return 1;
562     }
563
564     my %realclean := $!metadata.metadata<instructions><realclean>;
565     if %realclean {
566         say("\nRealcleaning $!name ...");
567
568         $*OS.chdir($!source_dir);
569
570         return self."realclean_{%realclean<type>}"();
571     }
572     else {
573         say("\nNo realclean method found for $!name.");
574         return 1;
575     }
576 }
577
578 method realclean_make () {
579     return do_run(%*BIN<make>, 'realclean');
580 }
581
582 method realclean_rake () {
583     return do_run(%*BIN<rake>, 'clobber');
584 }