nailing-cargo

   1 #!/usr/bin/perl -w
   2 # nailing-cargo: wrapper to use unpublished local crates
   3 # SPDX-License-Identifier: AGPL-3.0-or-later
   4 our $usage = <<'END';
   5
   6 usages:
   7
   8   nailing-cargo <nailing-opts> <cargo-opts> [--] <subcmd>...
   9   nailing-cargo <nailing-opts> --- <cargo> <cargo-opts> [--] <subcmd>...
  10   nailing-cargo <nailing-opts> --- [--] <build-command>...
  11
  12 options:
  13
  14   -v  Increase verbosity.  (Default is 1)
  15   -q  Set verbosity to 0
  16   -D  Increase amount of debugging dump.
  17   -n  "No action": stop after writing Cargo.toml.nailing~
  18       everywhere, and do not run any build command
  19
  20   -c  Do add cargo command line options      } default is add if
  21   -C  Do not add cargo command line options  }  command is cargo
  22
  23   -o --online                     -O --offline
  24   -u --cargo-lock-update          -U --no-cargo-lock-update
  25
  26   -T<arch>  --target=<arch>       Specify target architecture
  27   -h --help                       Print this message
  28   --doc --man --manual            Display complete manual (in w3m)
  29   --leave-nailed                  Leave the nailed Cargo.toml in place
  30   --just-linkfarm | --clean-linkfarm | --keep-linkfarm (default is keep)
  31   --[no-]preclean-linkfarm[=no|src|full]               (default is no)
  32   --just-run                      Run the command, don't do cargo stuff
  33   --no-nail                       Do not nail, just run the command.
  34   --no-cargo-lock-manip           Do not manipulate Cargo.lock.
  35   --no-concurrency-lock           Do not take the concurrency lock.
  36
  37   -s<subcommand>                  Treat command as `cargo <subcommand>`
  38   --subcommand-props=<prop>,...   Override command props (see docs)
  39
  40 END
  41
  42 our $self;
  43
  44 use strict;
  45 use POSIX;
  46 use Types::Serialiser;
  47 use File::Glob qw(bsd_glob GLOB_ERR GLOB_BRACE GLOB_NOMAGIC);
  48 use Cwd qw(realpath);
  49
  50 our $base_path;
  51 our %archmap = (
  52     RPI => 'arm-unknown-linux-gnueabihf',
  53     WASM => 'wasm32-unknown-unknown',
  54 );
  55
  56 BEGIN {
  57   $self = $0;  $self =~ s{^.*/(?=.)}{};
  58   my $deref = $0;
  59   our $base_path;
  60   while ($deref =~ m{^/}) {
  61     my $link = readlink $deref;
  62     if (!defined $link) {
  63       $! == EINVAL
  64         or die "$self: checking our script location $deref: $!\n";
  65       $deref =~ s{/[^/]+$}{}
  66         or die "$self: unexpected script path: $deref\n";
  67       $base_path = $deref;
  68       unshift @INC, $deref."/TOML-Tiny/lib";
  69       last;
  70     }
  71     last if $link !~ m{^/};
  72     $deref = $link;
  73   }
  74 }
  75
  76 use Fcntl qw(LOCK_EX);
  77 use File::Compare;
  78 use TOML::Tiny::Faithful;
  79
  80 our $src_absdir = getcwd() // die "$self: getcwd failed: $!\n";
  81
  82 our $worksphere = $src_absdir;
  83 $worksphere =~ s{/([^/]+)$}{}
  84   or die "$self: cwd \`$worksphere' unsupported!\n";
  85 our $subdir = $1; # leafname
  86
  87 our $lockfile = "../.nailing-cargo.lock";
  88
  89 our @args_preface;
  90 our $cargo_subcmd;
  91 our $command_is_cargo;
  92 our $alt_cargo_lock;
  93 our $cargo_lock_update;
  94 our $pass_options;
  95 our $online;
  96 our $just_linkfarm;
  97 our $leave_nailed;
  98 our $oot_clean;
  99 our $oot_preclean;
 100 our $do_nail=1;
 101 our $do_cargo_lock=1;
 102 our $do_lock=1;
 103 our $linkfarm_depth;
 104
 105 #
 106 our %subcmd_props = (
 107 # build (default)  =>[qw(                                                )],
 108 'generate-lockfile'=>[qw( lock-update !target          !target-dir       )],
 109  update            =>[qw( lock-update !target online                     )],
 110  fetch             =>[qw(                     online   !target-dir       )],
 111  fmt               =>[qw( !locked     !target !offline !target-dir edits )],
 112  miri              =>[qw( !locked             !offline  linkfarm-shallow )],
 113  upgrades          =>[qw( !locked                      !target-dir       )],
 114                     );
 115
 116 our @subcmd_xprops = qw(!manifest-path);
 117
 118 our @configs;
 119 our $verbose=1;
 120 our ($noact,$dump);
 121 our $target;
 122
 123 sub print_usage () {
 124   print $usage or die $!;
 125   exit 0;
 126 }
 127
 128 sub show_manual () {
 129   my $manual = ($base_path // '.').'/README.md';
 130   stat $manual or die "$self: manual not found at $manual: $!\n";;
 131   exec 'sh','-ec', 'pandoc -- "$1" 2>&1 | w3m -T text/html', '--', $manual;
 132   die "$self: exec sh failed: $!";
 133 }
 134
 135 sub read_or_enoent ($) {
 136   my ($fn) = @_;
 137   if (!open R, '<', $fn) {
 138     return undef if $!==ENOENT;
 139     die "$self: open $fn: $!\n";
 140   }
 141   local ($/) = undef;
 142   my ($r) = <R> // die "$self: read $fn: $!\n";
 143   $r;
 144 }
 145
 146 sub stat_exists ($$) {
 147   my ($fn, $what) = @_;
 148   if (stat $fn) { return 1; }
 149   $!==ENOENT or die "$self: stat $what: $fn: $!\n";
 150   return 0;
 151 }
 152
 153 sub subcmd_p ($) {
 154   print STDERR " subcmd_p ".(join ' ', keys %$cargo_subcmd)."   | @_\n"
 155     if $dump;
 156   $cargo_subcmd->{$_[0]}
 157 }
 158
 159 sub toml_or_enoent ($$) {
 160   my ($f,$what) = @_;
 161   my $toml = read_or_enoent($f) // return;
 162   print STDERR "Read TOML from $f\n" if $dump;
 163   my ($v,$e) = from_toml($toml);
 164   if (!defined $v) {
 165     chomp $e;
 166     die "$self: parse TOML: $what: $f: $e\n";
 167   }
 168   die "$e ?" if length $e;
 169   $v;
 170 }
 171
 172 sub load1config ($) {
 173   my ($f) = @_;
 174   my $toml = toml_or_enoent($f, "config file");
 175   push @configs, $toml if defined $toml;
 176 }
 177
 178 sub loadconfigs () {
 179   my $dotfile = ".nailing-cargo.toml";
 180   load1config("../Nailing-Cargo.toml");
 181   load1config($dotfile);
 182   load1config("$ENV{HOME}/$dotfile") if defined $ENV{HOME};
 183   load1config("/etc/nailing-cargo/cfg.toml");
 184 }
 185
 186 sub unlink_or_enoent ($) { unlink $_[0] or $!==ENOENT; }
 187
 188 sub same_file ($$) {
 189   my ($x,$y) = @_;
 190   "@$x[0..5]" eq "@$y[0..5]";
 191 }
 192
 193 sub takelock () {
 194   return unless $do_lock;
 195
 196   for (;;) {
 197     open LOCK, ">", $lockfile or die "$self: open/create $lockfile: $!\n";
 198     flock LOCK, LOCK_EX or die "$self: lock $lockfile: $!\n";
 199     my @fstat = stat LOCK or die "$self: fstat: $!\n";
 200     my @stat  = stat $lockfile;
 201     if (!@stat) {
 202       next if $! == ENOENT;
 203       die "$self: stat $lockfile: $!\n";
 204     }
 205     last if same_file(\@fstat,\@stat);
 206   }
 207 }
 208 sub unlock () {
 209   unlink $lockfile or die "$self: removing lockfile: $!\n";
 210 }
 211
 212 our $nail;
 213
 214 sub badcfg {
 215   my $m = pop @_;
 216   $" = '.';
 217   die "$self: config key \`@_': $m\n";
 218 }
 219
 220 sub cfg_uc {
 221   foreach my $cfg (@configs) {
 222     my $v = $cfg;
 223     foreach my $k (@_) {
 224       last unless defined $v;
 225       ref($v) eq 'HASH' or badcfg @_, "parent key \`$k' is not a hash";
 226       $v = $v->{$k};
 227     }
 228     return $v if defined $v;
 229   }
 230   return undef;
 231 }
 232
 233 sub cfge {
 234   my $exp = shift @_;
 235   my $v = cfg_uc @_;
 236   my $got = ref($v) || 'scalar';
 237   return $v if !defined($v) || $got eq $exp;
 238   badcfg @_, "found \L$got\E, expected \L$exp\E";
 239   # ^ toml doesn't make refs to scalars, so this is unambiguous
 240 }
 241
 242 sub cfgn {
 243   my $exp = shift @_;
 244   (cfge $exp, @_) // badcfg @_, "missing";
 245 }
 246
 247 sub cfgs  { cfge 'scalar', @_ }
 248 sub cfgsn { cfgn 'scalar', @_ }
 249
 250 sub cfg_bool {
 251   my $v = cfg_uc @_;
 252   return $v if !defined($v) || Types::Serialiser::is_bool $v;
 253   badcfg @_, "expected boolean";
 254 }
 255
 256 sub cfgn_list {
 257   my $l = cfge 'ARRAY', @_;
 258   foreach my $x (@$l) {
 259     !ref $x or badcfg @_, "list contains non-scalar element";
 260   }
 261   @$l
 262 }
 263
 264 sub readnail () {
 265   my $nailfile = "../Cargo.nail";
 266   open N, '<', $nailfile or die "$self: open $nailfile: $!\n";
 267   local ($/) = undef;
 268   my $toml = <N> // die "$self: read $nailfile: $!";
 269   my $transformed;
 270   if ($toml !~ m{^\s*\[/}m &&
 271       $toml !~ m{^[^\n\#]*\=}m &&
 272       # old non-toml syntax
 273       $toml =~ s{^[ \t]*([-_0-9a-z]+)[ \t]+(\S+)[ \t]*$}{$1 = \"$2\"}mig) {
 274     $toml =~ s{^}{[packages\]\n};
 275     my @sd;
 276     $toml =~ s{^[ \t]*\-[ \t]*\=[ \t]*(\"[-_0-9a-z]+\"\n?)$}{
 277       push @sd, $1; '';
 278     }mige;
 279     $toml = "subdirs = [\n".(join '', map { "$_\n" } @sd)."]\n".$toml;
 280     $transformed = 1;
 281   }
 282   my $e;
 283   ($nail,$e) = from_toml($toml);
 284   if (!defined $nail) {
 285     if ($transformed) {
 286       $toml =~ s/^/    /mg;
 287       print STDERR "$self: $nailfile transformed into TOML:\n$toml\n";
 288     }
 289     $/="\n"; chomp $e;
 290     die "$self: parse $nailfile: $e\n";
 291   }
 292   die "$e ?" if length $e;
 293
 294   $nail->{subdirs} //= [ ];
 295
 296   if (!ref $nail->{subdirs}) {
 297     $nail->{subdirs} = [
 298       grep /^[^\#]/,
 299       map { s/^\s+//; s/\s+$//; $_; }
 300       split m{\n},
 301       $nail->{subdirs}
 302     ];
 303   }
 304
 305   unshift @configs, $nail;
 306 }
 307
 308 sub get_dependency_tables ($) {
 309   my ($toml) = @_;
 310   my @keys = qw(dependencies build-dependencies dev-dependencies);
 311   my @r;
 312   my $process = sub {
 313     my ($node) = @_;
 314     foreach my $k (@keys) {
 315       my $deps = $node->{$k};
 316       push @r, $deps if $deps;
 317     }
 318   };
 319   $process->($toml);
 320   foreach my $target_node (values %{ $toml->{target} // { } }) {
 321     $process->($target_node);
 322   }
 323   @r;
 324 }
 325
 326 our @alt_cargo_lock_stat;
 327
 328 sub consider_alt_cargo_lock () {
 329   my @ck = qw(alt_cargo_lock);
 330   # User should *either* have Cargo.lock in .gitignore,
 331   # or expect to commit Cargo.lock.example ($alt_cargo_lock)
 332
 333   return unless $do_cargo_lock;
 334
 335   $alt_cargo_lock = (cfg_uc @ck);
 336
 337   my $force = 0;
 338   if (defined($alt_cargo_lock) && ref($alt_cargo_lock) eq 'HASH') {
 339     $force = cfg_bool qw(alt_cargo_lock force);
 340     my @ck = qw(alt_cargo_lock file);
 341     $alt_cargo_lock = cfg_uc @ck;
 342   }
 343   $alt_cargo_lock //= Types::Serialiser::true;
 344
 345   if (Types::Serialiser::is_bool $alt_cargo_lock) {
 346     if (!$alt_cargo_lock) { $alt_cargo_lock = undef; return; }
 347     $alt_cargo_lock = 'Cargo.lock.example';
 348   }
 349
 350   if (ref($alt_cargo_lock) || $alt_cargo_lock =~ m{/}) {
 351     badcfg @ck, "expected boolean, or leafname";
 352   }
 353
 354   if (!stat_exists $alt_cargo_lock, "alt_cargo_lock") {
 355     $alt_cargo_lock = undef unless $force;
 356     return;
 357   }
 358
 359   @alt_cargo_lock_stat = stat _;
 360 }
 361
 362 our $oot_dir;      # oot.dir or "Build"
 363 our $oot_absdir;
 364
 365 sub consider_oot () {
 366   $oot_dir = cfgs qw(oot dir);
 367   my $use = cfgs qw(oot use);
 368   unless (defined($oot_dir) || defined($use) ||
 369           defined(cfg_uc qw(oot user))) {
 370     return;
 371   }
 372   if (($use//'') eq 'disable') {
 373     $oot_dir = undef;
 374     return;
 375   }
 376   $oot_clean //= cfg_bool qw(oot clean);
 377   $oot_dir //= 'Build';
 378   $oot_absdir = ($oot_dir !~ m{^/} ? "$worksphere/" : ""). $oot_dir;
 379 }
 380
 381 our %manifests;
 382 our %packagemap;
 383 our %workspaces;
 384 our @queued_paths;
 385
 386 sub read_manifest ($$$) {
 387   my ($subdir, $org_subdir, $why) = @_;
 388   my $manifest = "../$subdir/Cargo.toml";
 389   print STDERR "$self: reading $manifest...\n" if $verbose>=4;
 390   if (defined $manifests{$manifest}) {
 391     print STDERR
 392  "$self: warning: $subdir: specified more than once!".
 393  " (ignoring $why)\n";
 394     return undef;
 395   }
 396   foreach my $try ("$manifest.unnailed", "$manifest") {
 397     my $toml = toml_or_enoent($try, "manifest, in $why") // next;
 398     my $ws = $toml->{workspace};
 399     if ($ws) {
 400       queue_workspace_members($subdir, $org_subdir, $ws, "$subdir, $why");
 401     }
 402     my $p = $toml->{package}{name};
 403     if (!defined $p and !defined $ws) {
 404       print STDERR
 405  "$self: warning: $subdir, $why: missing package.name in $try, ignoring\n";
 406       next;
 407     }
 408     $manifests{$manifest} = [ $toml, $org_subdir ] if $p;
 409     foreach my $dep (get_dependency_tables $toml) {
 410       next unless defined $dep->{path};
 411       queue_referenced_path($dep->{path}, $org_subdir,
 412                             "dependency of $subdir, $why");
 413     }
 414     return ($p, $ws);
 415   }
 416   return undef;
 417 }
 418
 419 sub queue_workspace_members ($$) {
 420   my ($subdir, $org_subdir, $ws_toml, $what) = @_;
 421   # We need to (more or less) reimplement the cargo workspace
 422   # membership algorithm (see the "workspaces" section of the cargo
 423   # reference).  How tiresome.
 424   #
 425   # It's not quite the same for us because we aren't interested in
 426   # whether cargo thinks things are "in the workspace".  But we do
 427   # need to do the automatic discover.
 428
 429   my @include = @{ $ws_toml->{members} // [ ] };
 430   my $exclude = $ws_toml->{exclude} // [ ];
 431
 432   my @exclude = map {
 433     s/[^*?0-9a-zA-Z_]/\\$&/g;
 434     s/\?/./g;
 435     s/\*/.*/g;
 436   } @$exclude;
 437
 438   foreach my $spec (@include) {
 439     if ($spec =~ m{^/}) {
 440       print STDERR
 441         "$self: warning: absolute workspace member $spec in $what (not nailing, but cargo will probably use it)\n";
 442       next;
 443     }
 444     my $spec_glob = "../$subdir/$spec";
 445     my $globflags = GLOB_ERR|GLOB_BRACE|GLOB_NOMAGIC;
 446     foreach my $globent (bsd_glob($spec_glob, $globflags)) {
 447       next if grep { $globent =~ m{^$_$} } @exclude;
 448       queue_referenced_path($globent, $org_subdir,
 449                             "member of workspace $what");
 450     }
 451   }
 452 }
 453
 454 sub queue_referenced_path ($$$) {
 455   my ($spec_path, $org_subdir, $why) = @_;
 456   open REALPATH, "-|",
 457     qw(realpath), "--relative-to=../$org_subdir", "--", $spec_path
 458     or die "$self: fork/pipe/exec for realpath(1)\n";
 459   my $rel_path = do { local $/=undef; <REALPATH>; };
 460   $?=0; $!=0;
 461   my $r = close(REALPATH);
 462   die "$self: reap realpath: $!\n" if $!;
 463   if (!chomp($rel_path) or $?) {
 464     print STDERR
 465  "$self: warning: failed to determine realpath for $spec_path in $org_subdir (exit code $?)\n";
 466     return;
 467   }
 468   if ($rel_path =~ m{^\.\./} or $rel_path eq '..') {
 469     print STDERR
 470       "$self: warning: $spec_path ($why) points outside $org_subdir, not following so not nailing (although cargo probably will follow it)\n";
 471     return;
 472   }
 473
 474   my $q_subdir = "$org_subdir/$rel_path";
 475   print STDERR "$self: making a note to look at $q_subdir, $why)\n"
 476     if $verbose >= 4;
 477
 478   push @queued_paths, [ "$q_subdir", $org_subdir, $why ];
 479 }
 480
 481 sub readorigs () {
 482   # We (and our callees) populate %packagemap and %manifest, so if we
 483   # don't run, they remain empty and nothing is nailed.
 484   return unless $do_nail;
 485
 486   foreach my $p (keys %{ $nail->{packages} }) {
 487     my $v = $nail->{packages}{$p};
 488     my $subdir = ref($v) ? $v->{subdir} : $v;
 489     my ($gotpackage, $ws) = read_manifest($subdir, $subdir, "from [packages]");
 490     $gotpackage //= '<nothing!>';
 491     if ($gotpackage ne $p) {
 492       print STDERR
 493  "$self: warning: honouring Cargo.nail packages.$subdir=$p even though $subdir contains package $gotpackage!\n";
 494     }
 495     die if defined $packagemap{$p};
 496     $packagemap{$p} = [ $subdir, $subdir ];
 497   }
 498   foreach my $subdir (@{ $nail->{subdirs} }) {
 499     my ($gotpackage,$ws) = read_manifest($subdir, $subdir, "from [subdirs]");
 500     if (!defined $gotpackage) {
 501       print STDERR
 502  "$self: warning: ignoring subdir $subdir which has no (suitable) Cargo.toml\n"
 503         unless $ws;
 504       next;
 505     }
 506     $packagemap{$gotpackage} //= [ $subdir, $subdir ];
 507   }
 508   while (my ($subdir, $org_subdir, $why) = @{ shift @queued_paths or [] }) {
 509     next if $manifests{"../$subdir/Cargo.toml"};
 510     my ($gotpackage, $ws) = read_manifest($subdir, $org_subdir, $why);
 511     next unless $gotpackage;
 512     $packagemap{$gotpackage} //= [ $subdir, $org_subdir ];
 513   }
 514 }
 515
 516 sub calculate () {
 517   foreach my $p (sort keys %packagemap) {
 518     print STDERR "$self: package $p in $packagemap{$p}[0]\n" if $verbose>=2;
 519   }
 520   foreach my $mf (keys %manifests) {
 521     die "internal error" unless $do_nail; # belt and braces
 522
 523     my ($toml, $mf_org_subdir) = @{ $manifests{$mf} };
 524     foreach my $deps (get_dependency_tables $toml) {
 525       next unless $deps;
 526       foreach my $p (keys %packagemap) {
 527         my $info = $deps->{$p};
 528         next unless defined $info;
 529         next if $packagemap{$p}[1] eq $mf_org_subdir;
 530         $deps->{$p} = $info = { } unless ref $info;
 531         my $oldpath = $info->{path};
 532         delete $info->{version};
 533         my $newpath = $worksphere.'/'.$packagemap{$p}[0];
 534         print STDERR "in $mf set $p path=$newpath (was ".
 535           ($oldpath // '<unset>').")\n"
 536           if $verbose >= 4;
 537         $info->{path} = $newpath;
 538         delete $info->{git};
 539         delete $info->{branch};
 540       }
 541     }
 542     my $nailing = "$mf.nailing~";
 543     unlink_or_enoent $nailing or die "$self: remove old $nailing: $!\n";
 544     open N, '>', $nailing or die "$self: create new $nailing: $!\n";
 545     print N to_toml($toml) or die "$self: write new $nailing: $!\n";
 546     close N or die "$self: close new $nailing: $!\n";
 547   }
 548 }
 549
 550 sub addargs () {
 551   if ($just_linkfarm) {
 552     die "$self: --just-linkfarm but not doing out-of-tree builds!\n"
 553       unless defined $oot_dir;
 554     @ARGV = ();
 555     return;
 556   }
 557
 558   if (!defined $online) {
 559     $_ = cfg_uc qw(misc online);
 560     if (!defined $_) {
 561     } elsif (Types::Serialiser::is_bool $_) {
 562       $online = $_;
 563     } elsif (ref $_) {
 564     } elsif (m/^a/) {
 565       $online = undef;
 566     } elsif (m/^[1ty]/) { # allow booleanish strings
 567       $online = 1;        # for less user frustration
 568     } elsif (m/^[0fn]/) {
 569       $online = 0;
 570     } else {
 571       badcfg qw(misc online), "expected boolean or 'auto', found '$_'";
 572     }
 573   }
 574   $online //= 1 if subcmd_p('online');
 575   $online //= 0;
 576
 577   $cargo_lock_update //= subcmd_p('lock-update');
 578   $linkfarm_depth //=
 579     subcmd_p('linkfarm-shallow') ? 'shallow' :
 580     $cargo_lock_update           ? 'shallow' :
 581     '';
 582
 583   $oot_preclean //= 'no';
 584
 585   our @add;
 586
 587   if (!$cargo_lock_update) {
 588     push @add, qw(--locked) unless subcmd_p('!locked');
 589   }
 590   if ($linkfarm_depth eq '') {
 591     if (defined($oot_dir) && !subcmd_p('!manifest-path')) {
 592       my $cargotoml = "${src_absdir}/Cargo.toml";
 593       push @args_preface, "--manifest-path=$cargotoml" if $pass_options;
 594       push @add, qw(--target-dir=target) unless subcmd_p('!target-dir');
 595     }
 596   }
 597
 598   if (defined($target) && !subcmd_p('!target')) {
 599     if ($target =~ m{^[A-Z]}) {
 600       $target = (cfgs 'arch', $target) // $archmap{$target}
 601         // die "$self: --target=$target alias specified; not in cfg or map\n";
 602     }
 603     push @add, "--target=$target";
 604   }
 605
 606   push @add, "--offline" unless $online || subcmd_p('!offline');
 607
 608   if (subcmd_p('edits') && $linkfarm_depth ne 'copy-edit') {
 609     print STDERR
 610  "$self: *WARNING*: this subcommand expects to edit the source code; you probably want to specify --edits-sources aka -E (which is not the default even now, for safety reasons)\n";
 611   }
 612
 613   push @args_preface, @add if $pass_options;
 614   die if grep { m/ / } @add;
 615   $ENV{NAILINGCARGO_CARGO_OPTIONS} = "@add";
 616
 617   unshift @ARGV, @args_preface;
 618 }
 619
 620 our $build_absdir; # .../Build/<subdir>
 621
 622 sub oot_massage_cmdline () {
 623   return unless defined $oot_dir;
 624
 625   my $use = cfgs qw(oot use);
 626   $use // die "$self: out-of-tree build, but \`oot.use' not configured\n";
 627   $build_absdir = "$oot_absdir/$subdir";
 628
 629   my ($pre,$post) = ('','');
 630   my @xargs;
 631   if ($linkfarm_depth eq '') {
 632     push @xargs, $build_absdir;
 633     ($pre, $post) = ('cd "$1"; shift; ', '');
 634   } else {
 635     push @xargs, $oot_absdir, $subdir, $src_absdir;
 636     $pre = <<'END_BOTH';
 637         bld="$1"; shift; sd="$1"; shift; src="$1"; shift;
 638         cd "$bld"; mkdir -p -- "$sd"; cd "$sd";
 639 END_BOTH
 640     if ($oot_preclean ne 'no') {
 641       $pre.= "find . -maxdepth 1 ! -path .";
 642       $pre.= " ! -path ./target" if $oot_preclean ne 'full';
 643       $pre.= " -print0 | xargs -0r echo rm -r --;"
 644     }
 645     if ($linkfarm_depth eq 'shallow') {
 646       $pre.= <<'END_SHALLOW';
 647         clean () { find -lname "$src/*" -print0 | xargs -0r rm --; }; clean;
 648         find "$src" -maxdepth 1 \! -name Cargo.lock -print0 |
 649         xargs -0r sh -ec 'for f in "$@"; do
 650                 rm -rf "${f##*/}";
 651                 ln -sf -- "$f" .;
 652         done';
 653 END_SHALLOW
 654     } elsif ($linkfarm_depth =~ /full|git/) {
 655       $pre .= <<'END_EITHER_DEEP_DIRS';
 656         clean () { find -follow -lname "$src/*" -print0 | xargs -0r rm --; };
 657         (set -e; cd "$src"; find . \! -name Cargo.lock \! \( -name .git -prune \) \! -path . \! -name .git -type d -print0) |
 658         xargs -0r sh -ec 'for f in "$@"; do
 659                 rm -f "$f" 2>/dev/null ||:;
 660                 mkdir -p "$f";
 661         done' x;
 662 END_EITHER_DEEP_DIRS
 663       if ($linkfarm_depth eq 'git') {
 664         $pre .= <<'END_FILES_GIT'
 665         (set -e; cd "$src"; git ls-files --exclude-standard -co -z) |
 666 END_FILES_GIT
 667       } elsif ($linkfarm_depth eq 'full') {
 668         $pre .= <<'END_FILES_FULL'
 669         (set -e; cd "$src"; find . \! -name Cargo.lock \! \( -name .git -prune \) \! -type d -print0) |
 670 END_FILES_FULL
 671       }
 672       $pre .= <<'END_DEEP';
 673         perl -0 -ne '
 674                 BEGIN { $src=shift @ARGV; }
 675                 next if (readlink "$_"//"") eq "$src/$_";
 676                 unlink "$_";
 677                 symlink "$src/$_", "$_" or die "$_ $!";
 678         ' "$src";
 679 END_DEEP
 680     } elsif ($linkfarm_depth eq 'copy-edit') {
 681       $pre .= <<'END_COPY_EDIT';
 682         find -lname "$src/*" -print0 | xargs -0r rm --;
 683         (set -e; cd "$src"; git ls-files -c -z |
 684         cpio --quiet -p0m --no-preserve-owner -u --make-directories "$bld/$sd");
 685         clean () {
 686           (set -e; cd "$src"; git ls-files -c -z) | xargs -0r rm -f --;
 687         };
 688 END_COPY_EDIT
 689       $post .= <<'END_COPY_EDIT_BUNDLE';
 690         (set -e; cd "$src"; git ls-files -c -z) |
 691         cpio -Hustar -o0 --quiet >"nailing-cargo-update.tar";
 692 END_COPY_EDIT_BUNDLE
 693     } else {
 694        die "$linkfarm_depth ?";
 695     }
 696     $pre .= <<'ENDLK' if $do_cargo_lock;
 697         if test -e Cargo.lock; then
 698           rm -f Cargo.lock;
 699           cp -- "$src"/Cargo.lock .;
 700         fi;
 701 ENDLK
 702     $post .= <<'ENDCLEAN' if $oot_clean && !$just_linkfarm;
 703         clean;
 704 ENDCLEAN
 705   }
 706   my $addpath = (cfg_uc qw(oot path_add)) //
 707     $use eq 'really' ? Types::Serialiser::true : Types::Serialiser::false;
 708   $addpath =
 709     !Types::Serialiser::is_bool $addpath ? $addpath           :
 710     $addpath                             ? '$HOME/.cargo/bin' :
 711                                            undef;
 712   if (defined $addpath) {
 713     $pre .= <<END
 714         PATH=$addpath:\${PATH-/usr/local/bin:/bin:/usr/bin};
 715         export PATH;
 716 END
 717   }
 718   $pre  =~ s/^\s+//mg; $pre  =~ s/\s+/ /g;
 719   $post =~ s/^\s+//mg; $post =~ s/\s+/ /g;
 720
 721   my $getuser = sub { cfgsn qw(oot user) };
 722   my @command;
 723   my $xe = $verbose >= 2 ? 'xe' : 'e';
 724   my $sh_ec = sub {
 725     if (!length $post) {
 726       @command = (@_, 'sh',"-${xe}c",$pre.'exec "$@"','--',@xargs);
 727     } else {
 728       @command = (@_, 'sh',"-${xe}c",$pre.'"$@"; '.$post,'--',@xargs);
 729     }
 730     push @command, @ARGV;
 731   };
 732   my $command_sh = sub {
 733     my $quoted = join ' ', map {
 734       return $_ if !m/\W/;
 735       s/\'/\'\\'\'/g;
 736       "'$_'"
 737     } @ARGV;
 738     @command = @_, "set -${xe}; $pre $quoted; $post";
 739   };
 740   print STDERR "$self: out-of-tree, building in: \`$build_absdir'\n"
 741     if $verbose;
 742   if ($use eq 'really') {
 743     my $user = $getuser->();
 744     my @pw = getpwnam $user or die "$self: oot.user \`$user' lookup failed\n";
 745     my $homedir = $pw[7];
 746     $sh_ec->('really','-u',$user,'env',"HOME=$homedir");
 747     print STDERR "$self: using really to run as user \`$user'\n" if $verbose;
 748   } elsif ($use eq 'ssh') {
 749     my $user = $getuser->();
 750     $user .= '@localhost' unless $user =~ m/\@/;
 751     $command_sh->('ssh',$user);
 752     print STDERR "$self: using ssh to run as \`$user'\n" if $verbose;
 753   } elsif ($use eq 'command_args') {
 754     my @c = cfgn_list qw(oot command);
 755     $sh_ec->(@c);
 756     print STDERR "$self: out-of-tree, adverbial command: @c\n" if $verbose;
 757   } elsif ($use eq 'command_sh') {
 758     my @c = cfgn_list qw(oot command);
 759     $command_sh->(@c);
 760     print STDERR "$self: out-of-tree, ssh'ish command: @c\n" if $verbose;
 761   } elsif ($use eq 'null') {
 762     $sh_ec->();
 763   } else {
 764     die "$self: oot.use mode $use not recognised\n";
 765   }
 766   die unless @command;
 767   @ARGV = @command;
 768 }
 769
 770 sub setenvs () {
 771   $ENV{CARGO_MANIFEST_DIR} = $src_absdir unless $linkfarm_depth;
 772   $ENV{NAILINGCARGO_MANIFEST_DIR} = $src_absdir;
 773   $ENV{NAILINGCARGO_WORKSPHERE}   = $worksphere;
 774   $ENV{NAILINGCARGO_BUILDSPHERE}  = $oot_absdir;
 775   delete $ENV{NAILINGCARGO_BUILDSPHERE} unless $oot_absdir;
 776   $ENV{NAILINGCARGO_BUILD_DIR}    = $build_absdir // $src_absdir;
 777 }
 778
 779 our $want_uninstall;
 780
 781 END {
 782   if ($want_uninstall) {
 783     local ($?);
 784     foreach my $mf (keys %manifests) {
 785       eval { uninstall1($mf,1); 1; } or warn "$@";
 786     }
 787     eval { unaltcargolock(1); 1; } or warn "$@";
 788   }
 789 }
 790
 791 sub consider_directories () {
 792   return unless defined $oot_dir;
 793   my $bsubdir = "../$oot_dir/$subdir";
 794   return if stat $bsubdir;
 795   die "$0: build directory $bsubdir inaccessible\n"
 796     unless $!==ENOENT;
 797   return if $cargo_lock_update; # will make it
 798   die "$0: build directory $bsubdir does not exist, and not in Cargo.lock update mode!\n";
 799 }
 800
 801 our $cleanup_cargo_lock;
 802 sub makebackups () {
 803   foreach my $mf (keys %manifests) {
 804     link "$mf", "$mf.unnailed" or $!==EEXIST
 805       or die "$self: make backup link $mf.unnailed: $!\n";
 806   }
 807
 808   if (defined($alt_cargo_lock)) {
 809     die 'internal error' unless $do_cargo_lock;
 810     if (@alt_cargo_lock_stat) {
 811       print STDERR "$self: using alt_cargo_lock `$alt_cargo_lock'..."
 812         if $verbose>=3;
 813       if (link $alt_cargo_lock, 'Cargo.lock') {
 814         print STDERR " linked\n" if $verbose>=3;
 815       } elsif ($! != EEXIST) {
 816         print STDERR "\n" if $verbose>=3;
 817         die "$self: make \`Cargo.lock' available as \`$alt_cargo_lock': $!\n";
 818       } else {
 819         print STDERR "checking quality." if $verbose>=3;
 820         my @lock_stat = stat 'Cargo.lock'
 821           or die "$self: stat Cargo.lock (for alt check: $!\n";
 822         same_file(\@alt_cargo_lock_stat, \@lock_stat)
 823           or die
 824 "$self: \`Cargo.lock' and alt file \`$alt_cargo_lock' both exist and are not the same file!\n";
 825       }
 826       $cleanup_cargo_lock = 1;
 827     } else {
 828       $cleanup_cargo_lock = 1;
 829       # If Cargo.lock exists and alt doesn't, that means either
 830       # that a previous run was interrupted, or that the user has
 831       # messed up.
 832     }
 833   }
 834 }
 835
 836 sub nailed ($) {
 837   my ($mf) = @_;
 838   my $nailed  = "$mf.nailed~"; $nailed =~ s{/([^/]+)$}{/.$1} or die;
 839   $nailed;
 840 }
 841
 842 sub install () {
 843   my @our_unfound_stab = stat_exists('Cargo.toml', 'local Cargo.toml')
 844     ? (stat _) : ();
 845   foreach my $mf (keys %manifests) {
 846     if (@our_unfound_stab) {
 847       if (stat_exists $mf, "manifest in to-be-nailed directory") {
 848         my @mf_stab = stat _ ;
 849         if ("@mf_stab[0..1]" eq "@our_unfound_stab[0..1]") {
 850           @our_unfound_stab = ();
 851         }
 852       }
 853     }
 854
 855     my $nailing = "$mf.nailing~";
 856     my $nailed = nailed($mf);
 857     my ($use, $rm);
 858     my $diff;
 859     if (open NN, '<', $nailed) {
 860       $diff = compare($nailing, \*NN);
 861       die "$self: compare $nailing and $nailed: $!" if $diff<0;
 862     } else {
 863       $!==ENOENT or die "$self: check previous $nailed: $!\n";
 864       $diff = 1;
 865     }
 866     if ($diff) {
 867       $use = $nailing;
 868       $rm  = $nailed;
 869     } else {
 870       $use = $nailed;
 871       $rm  = $nailing;
 872     }
 873     rename $use, $mf or die "$self: install nailed $use: $!\n";
 874     unlink_or_enoent $rm or die "$self: remove old $rm: $!\n";
 875     print STDERR "$self: nailed $mf\n" if $verbose>=3;
 876   }
 877
 878   if (@our_unfound_stab && $do_nail) {
 879     print STDERR
 880  "$self: *WARNING* cwd is not in Cargo.nail thbough it has Cargo.toml!\n";
 881   }
 882 }
 883
 884 sub invoke () {
 885   my $r = system @ARGV;
 886   if (!$r) {
 887     return 0;
 888   } elsif ($r<0) {
 889     print STDERR "$self: could not execute $ARGV[0]: $!\n";
 890     return 127;
 891   } elsif ($r & 0xff00) {
 892     print STDERR "$self: $ARGV[0] failed (exit status $r)\n";
 893     return $r >> 8;
 894   } else {
 895     print STDERR "$self: $ARGV[0] died due to signal! (wait status $r)\n";
 896     return 125;
 897   }
 898 }
 899
 900 sub files_return_after_update () {
 901   if ($linkfarm_depth eq 'copy-edit') {
 902     system qw(sh -ec), <<'END', 'x', "$build_absdir";
 903       git ls-files -c -z | \
 904       tar -x --keep-newer-files --no-same-permissions --no-same-owner \
 905         --no-acls --no-selinux --no-xattrs --warning=no-ignore-newer \
 906         -Hustar --null --files-from=- --force-local \
 907         -f "$1/nailing-cargo-update.tar"
 908 END
 909   } elsif ($do_cargo_lock && $cargo_lock_update && !$just_linkfarm) {
 910     # avoids importing File::Copy and the error handling is about as good
 911     $!=0; $?=0;
 912     my $r= system qw(cp --), "$build_absdir/Cargo.lock", "Cargo.lock";
 913     die "$self: run cp: $! $?" if $r<0 || $r & 0xff;
 914     die "$self: failed to update local Cargo.lock (wait status $r)\n" if $r;
 915   }
 916 }
 917
 918 sub uninstall1 ($$) {
 919   my ($mf, $enoentok) = @_;
 920   my $unnailed = "$mf.unnailed";
 921   rename $unnailed, $mf or ($enoentok && $!==ENOENT)
 922     or die "$self: failed to restore: rename $unnailed back to $mf: $!\n";
 923 }
 924
 925 sub unaltcargolock ($) {
 926   my ($enoentok) = @_;
 927   return unless $cleanup_cargo_lock;
 928   die 'internal error!' unless $do_cargo_lock && defined $alt_cargo_lock;
 929
 930   # we ignore $enoentok because we don't know if one was supposed to
 931   # have been created.
 932
 933   rename('Cargo.lock', $alt_cargo_lock) or $!==ENOENT or die
 934  "$self: cleanup: rename possibly-updated \`Cargo.lock' to \`$alt_cargo_lock': $!\n";
 935
 936   unlink 'Cargo.lock' or $!==ENOENT or die
 937  "$self: cleanup: remove \`Cargo.lock' in favour of \`$alt_cargo_lock': $!\n";
 938   # ^ this also helps clean up the stupid rename() corner case
 939 }
 940
 941 sub uninstall () {
 942   foreach my $mf (keys %manifests) {
 943     my $nailed = nailed($mf);
 944     link $mf, $nailed or die "$self: preserve (link) $mf as $nailed: $!\n";
 945     uninstall1($mf,0);
 946   }
 947   unaltcargolock(0);
 948 }
 949
 950 sub parse_args () {
 951   my $is_cargo;
 952
 953   # Loop exit condition:
 954   #   $is_cargo is set
 955   #   @ARGV contains
 956   #    $is_cargo==1   <cargo-command> <cargo-opts> [--] <subcmd>...
 957   #    $is_cargo==0   <build-command>...
 958
 959  OPTS: for (;;) {
 960     if (!@ARGV) {
 961       die "$self: need cargo subcommand\n"
 962         unless $noact || $just_linkfarm;;
 963       push @ARGV, "CARGO-SUBCOMMAND"; # dummy, user may see it
 964     }
 965
 966     $_ = shift @ARGV;
 967     my $orgopt = $_;
 968
 969     my $not_a_nailing_opt = sub { # usage 1
 970       unshift @ARGV, $orgopt;
 971       unshift @ARGV, 'cargo';
 972       $is_cargo = 1;
 973       no warnings qw(exiting);
 974       last OPTS;
 975     };
 976     $not_a_nailing_opt->() unless m{^-};
 977     $not_a_nailing_opt->() if $_ eq '--';
 978
 979     if ($_ eq '---') { # usage 2 or 3
 980       if (!@ARGV) {
 981         die "$self: --- must be followed by build command\n" unless $noact;
 982         push @ARGV, 'BUILD-COMMAND';
 983       }
 984       if ($ARGV[0] eq '--') { # usage 3
 985         shift;
 986         $is_cargo = 0;
 987       } elsif (grep { $_ eq '--' } @ARGV) { # usage 2
 988         $is_cargo = 1;
 989       } elsif ($ARGV[0] =~ m{[^/]*cargo[^/]*$}) { # usage 2
 990         $is_cargo = 1;
 991       } else {  # usage 3
 992         $is_cargo = 0;
 993       }
 994       last;
 995     }
 996     if (m{^-[^-]}) {
 997       while (m{^-.}) {
 998         if (s{^-h}{-}) {
 999           print_usage();
1000         } elsif (s{^-v}{-}) {
1001           $verbose++;
1002         } elsif (s{^-q}{-}) {
1003           $verbose=0;
1004         } elsif (s{^-n}{-}) {
1005           $noact++;
1006         } elsif (s{^-s(.+)}{-}s) {
1007           $cargo_subcmd = $1;
1008         } elsif (s{^-([uU])}{-}) {
1009           $cargo_lock_update = $1=~m/[a-z]/;
1010         } elsif (s{^-([cC])}{-}) {
1011           $pass_options = $1=~m/[a-z]/;
1012         } elsif (s{^-D}{-}) {
1013           $dump++;
1014         } elsif (s{^-E}{-}) {
1015           $linkfarm_depth = 'copy-edit';
1016         } elsif (s{^-T(.+)}{-}s) {
1017           $target = $1;
1018         } elsif (s{^-([oO])}{-}) {
1019           $online = $1=~m/[a-z]/;
1020         } else {
1021           die "$self: unknown short option(s) $_\n" unless $_ eq $orgopt;
1022           $not_a_nailing_opt->();
1023         }
1024       }
1025     } elsif (s{^--help$}{}) {
1026       print_usage();
1027     } elsif (s{^--(?:doc|man|manual)?$}{}) {
1028       show_manual();
1029     } elsif (s{^--target=}{}) {
1030       $target = $_;
1031     } elsif (m{^--(on|off)line$}) {
1032       $online = $1 eq 'on';
1033     } elsif (m{^--just-linkfarm(?:=(shallow|git|full))?$}) {
1034       $just_linkfarm = 1;
1035       $linkfarm_depth = $1 if $1;
1036       $cargo_lock_update= 1; # will set $linkfarm_detph to 1 by default
1037     } elsif (m{^--linkfarm(?:=(no|shallow|git|full))?$}) {
1038       $linkfarm_depth = $1 || 'git';
1039     } elsif (m{^--edits?-sources?$}) {
1040       $linkfarm_depth = 'copy-edit';
1041     } elsif (m{^--just-run$}) {
1042       $do_nail = $do_cargo_lock = $do_lock = 0;
1043     } elsif (m{^--(clean|keep)-linkfarm$}) {
1044       $oot_clean = $1 eq 'clean';
1045     } elsif (m{^--(no-)?preclean-linkfarm$}) {
1046       $oot_preclean = $1 ? 'no' : 'src';
1047     } elsif (m{^--preclean-linkfarm=(no|src|full)$}) {
1048       $oot_preclean = $1;
1049     } elsif (m{^--(no-)?nail$}) {
1050       $do_nail = !$1;
1051     } elsif (m{^--(no-)?cargo-lock-manip$}) {
1052       $do_cargo_lock = !$1;
1053     } elsif (m{^--(no-)?concurrency-lock$}) {
1054       $do_lock = !$1;
1055     } elsif (m{^--leave-nailed$}) {
1056       $leave_nailed = 1;
1057     } elsif (s{^--subcommand-props=}{}) {
1058       my @props = split /\,/, $_;
1059       our %subcmd_prop_ok;
1060       if (!%subcmd_prop_ok) {
1061         foreach my $v (\@subcmd_xprops, values %subcmd_props) {
1062           $subcmd_prop_ok{$_}=1 foreach @$v;
1063         };
1064       }
1065       $subcmd_prop_ok{$_}
1066         or die "$self: unknown subcommand property \`$_'\n"
1067         foreach @props;
1068       $cargo_subcmd = \@props;
1069     } elsif (m{^--(no-)?cargo-lock-update}) {
1070       $cargo_lock_update= !!$1;
1071     } else {
1072       $not_a_nailing_opt->();
1073     }
1074   }
1075
1076   $is_cargo // die;
1077   @ARGV || die;
1078
1079   if ($is_cargo) {
1080     @args_preface = shift @ARGV;
1081     while (defined($_ = shift @ARGV)) {
1082       if (!m{^-|^\+}) { unshift @ARGV, $_; last; }
1083       if ($_ eq '--') { last; }
1084       push @args_preface, $_;
1085     }
1086     @ARGV || die "$self: need cargo subcommand\n";
1087     $cargo_subcmd //= $ARGV[0];
1088     $pass_options //= 1;
1089   } else {
1090     $cargo_subcmd //= '';
1091     $pass_options //= 0;
1092   }
1093   push @args_preface, shift @ARGV;
1094
1095   if (!ref($cargo_subcmd)) {
1096     print STDERR " cargo_subcmd lookup $cargo_subcmd\n" if $dump;
1097     $cargo_subcmd = $subcmd_props{$cargo_subcmd} // [ ];
1098   }
1099
1100   print STDERR " cargo_subcmd props @$cargo_subcmd\n" if $dump;
1101   my %cargo_subcmd;
1102   $cargo_subcmd{$_} = 1 foreach @$cargo_subcmd;
1103   $cargo_subcmd = \%cargo_subcmd;
1104 }
1105
1106 parse_args();
1107 loadconfigs();
1108 readnail();
1109 takelock();
1110 consider_alt_cargo_lock();
1111 consider_oot();
1112 readorigs();
1113 calculate();
1114 addargs();
1115 consider_directories();
1116 our @display_cmd = @ARGV;
1117 oot_massage_cmdline();
1118 setenvs();
1119
1120 if ($dump) {
1121   eval '
1122     use Data::Dumper;
1123     print STDERR Dumper(\%manifests) if $dump>=2;
1124     print STDERR Dumper(\%packagemap, \@ARGV,
1125                         { src_absdir => $src_absdir,
1126                           worksphere => $worksphere,
1127                           subdir => $subdir,
1128                           oot_dir => $oot_dir,
1129                           oot_absdir => $oot_absdir,
1130                           build_absdir => $build_absdir });
1131   ' or die $@;
1132 }
1133
1134 exit 0 if $noact;
1135
1136 $want_uninstall = !$leave_nailed;
1137 makebackups();
1138 install();
1139
1140 printf STDERR "$self: nailed (%s manifests, %s packages)%s\n",
1141   (scalar keys %manifests), (scalar keys %packagemap),
1142   (defined($alt_cargo_lock) and ", using `$alt_cargo_lock'")
1143   if $verbose && $do_nail;
1144
1145 print STDERR "$self: invoking: @display_cmd\n" if $verbose;
1146 my $estatus = invoke();
1147
1148 files_return_after_update();
1149
1150 uninstall() unless $leave_nailed;
1151 $want_uninstall = 0;
1152
1153 print STDERR "$self: ".($do_nail ? "unnailed" : "finished")
1154              .".  status $estatus.\n" if $verbose;
1155
1156 exit $estatus;