#!/usr/bin/perl -w
# nailing-cargo: wrapper to use unpublished local crates
#
# Copyright (C) 2019-2020 Ian Jackson
#
# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU Affero General Public License as
# published by the Free Software Foundation, either version 3 of the
# License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU Affero General Public License for more details.
#
# You should have received a copy of the GNU Affero General Public License
# along with this program. If not, see .
# example usages:
# ../nailing-cargo/nailing-caretwgo make
# ../nailing-cargo/nailing-cargo cargo build
# CARGO='../nailing-cargo/nailing-cargo cargo' make
# Why do we need this ?
#
# https://github.com/rust-lang/cargo/issues/6713
# https://stackoverflow.com/questions/33025887/how-to-use-a-local-unpublished-crate
# https://github.com/rust-lang/cargo/issues/1481
# Needs libtoml-perl
#: Cargo.nail:
#
# [packages]
# package = subdir
# package = { subdir = ... }
#
# [subdirs]
# subdir
use strict;
use TOML::Tiny::Faithful;
use POSIX;
use Fcntl qw(LOCK_EX);
use File::Compare;
my $self = $0; $self =~ s{^.*/(?=.)}{};
our $worksphere = getcwd() // die "$self: getcwd failed: $!\n";
$worksphere =~ s{/[^/]+$}{} or die "$self: cwd \`$worksphere' unsupported!\n";
our $lockfile = "../.nailing-cargo.lock";
our @configs;
our $verbose=1;
our ($noact,$dump);
sub read_or_enoent ($) {
my ($fn) = @_;
if (!open R, '<', $fn) {
return undef if $!==ENOENT;
die "$self: open $fn: $!\n";
}
local ($/) = undef;
my ($r) = // die "$self: read $fn: $!\n";
$r;
}
sub toml_or_enoent ($$) {
my ($f,$what) = @_;
my $toml = read_or_enoent($f) // return;
my ($v,$e) = from_toml($toml);
die "$self: parse TOML: $what: $f: $e\n" unless defined $v;
die "$e ?" if length $e;
$v;
}
sub load1config ($) {
my ($f) = @_;
my $toml = toml_or_enoent($f, "config file");
push @configs, $toml if defined $toml;
}
sub loadconfigs () {
my $cfgleaf = ".nailing-cargo-cfg.toml";
load1config("/etc/nailing-cargo/cfg.toml");
load1config("$worksphere/$cfgleaf");
load1config("$ENV{HOME}/$cfgleaf") if defined $ENV{HOME};
}
sub getcfg ($$) {
my ($k, $def) = @_;
foreach my $cfg (@configs) {
my $v = $cfg->{$k};
return $v if defined $v;
}
return $def;
}
sub unlink_or_enoent ($) { unlink $_[0] or $!==ENOENT; }
sub takelock () {
for (;;) {
open LOCK, ">", $lockfile or die "$self: open/create $lockfile: $!\n";
flock LOCK, LOCK_EX or die "$self: lock $lockfile: $!\n";
my @fstat = stat LOCK or die "$self: fstat: $!\n";
my @stat = stat $lockfile;
if (!@stat) {
next if $! == ENOENT;
die "$self: stat $lockfile: $!\n";
}
last if "@fstat[0..5]" eq "@stat[0..5]";
}
}
sub unlock () {
unlink $lockfile or die "$self: removing lockfile: $!\n";
}
our $nail;
sub readnail () {
my $nailfile = "../Cargo.nail";
open N, '<', $nailfile or die "$self: open $nailfile: $!\n";
local ($/) = undef;
my $toml = // die "$self: read $nailfile: $!";
my $transformed;
if ($toml !~ m{^\s*\[/}m &&
$toml !~ m{^[^\n\#]*\=}m &&
# old non-toml syntax
$toml =~ s{^[ \t]*([-_0-9a-z]+)[ \t]+(\S+)[ \t]*$}{$1 = \"$2\"}mig) {
$toml =~ s{^}{[packages\]\n};
my @sd;
$toml =~ s{^[ \t]*\-[ \t]*\=[ \t]*(\"[-_0-9a-z]+\"\n?)$}{
push @sd, $1; '';
}mige;
$toml = "subdirs = [\n".(join '', map { "$_\n" } @sd)."]\n".$toml;
$transformed = 1;
}
my $e;
($nail,$e) = from_toml($toml);
if (!defined $nail) {
if ($transformed) {
$toml =~ s/^/ /mg;
print STDERR "$self: $nailfile transformed into TOML:\n$toml\n";
}
die "$self: parse $nailfile: $e\n";
}
die "$e ?" if length $e;
}
our %manifests;
our %packagemap;
sub read_manifest ($) {
my ($subdir) = @_;
my $manifest = "../$subdir/Cargo.toml";
print STDERR "$self: reading $manifest...\n" if $verbose>=4;
if (defined $manifests{$manifest}) {
print STDERR
"$self: warning: $subdir: specified more than once!\n";
return undef;
}
foreach my $try ("$manifest.unnailed", "$manifest") {
my $toml = toml_or_enoent($try, "package manifest") // next;
my $p = $toml->{package}{name};
if (!defined $p) {
print STDERR
"$self: warning: $subdir: missing package.name in $try, ignoring\n";
next;
}
$manifests{$manifest} = $toml;
return $p;
}
return undef;
}
sub readorigs () {
foreach my $p (keys %{ $nail->{packages} }) {
my $v = $nail->{packages}{$p};
my $subdir = ref($v) ? $v->{subdir} : $v;
my $gotpackage = read_manifest($subdir) // '';
if ($gotpackage ne $p) {
print STDERR
"$self: warning: honouring Cargo.nail packages.$subdir=$p even though $subdir contains package $gotpackage!\n";
}
die if defined $packagemap{$p};
$packagemap{$p} = $subdir;
}
foreach my $subdir (@{ $nail->{subdirs} }) {
my $gotpackage = read_manifest($subdir);
if (!defined $gotpackage) {
print STDERR
"$self: warning: ignoring subdir $subdir which has no Cargo.toml\n";
next;
}
$packagemap{$gotpackage} //= $subdir;
}
}
sub calculate () {
foreach my $mf (keys %manifests) {
my $toml = $manifests{$mf};
foreach my $k (qw(dependencies build-dependencies dev-dependencies)) {
my $deps = $toml->{$k};
next unless $deps;
foreach my $p (keys %packagemap) {
my $info = $deps->{$p};
next unless defined $info;
$deps->{$p} = $info = { } unless ref $info;
delete $info->{version};
$info->{path} = $worksphere.'/'.$packagemap{$p};
}
}
my $nailing = "$mf.nailing~";
unlink_or_enoent $nailing or die "$self: remove old $nailing: $!\n";
open N, '>', $nailing or die "$self: create new $nailing: $!\n";
print N to_toml($toml) or die "$self: write new $nailing: $!\n";
close N or die "$self: close new $nailing: $!\n";
}
}
our $want_uninstall;
END {
if ($want_uninstall) {
local ($?);
foreach my $mf (keys %manifests) {
eval { uninstall1($mf,1); 1; } or warn "$@";
}
}
}
sub makebackups () {
foreach my $mf (keys %manifests) {
link "$mf", "$mf.unnailed" or $!==EEXIST
or die "$self: make backup link $mf.unnailed: $!\n";
}
}
sub nailed ($) {
my ($mf) = @_;
my $nailed = "$mf.nailed~"; $nailed =~ s{/([^/]+)$}{/.$1} or die;
$nailed;
}
sub install () {
foreach my $mf (keys %manifests) {
my $nailing = "$mf.nailing~";
my $nailed = nailed($mf);
my ($use, $rm);
my $diff;
if (open NN, '<', $nailed) {
$diff = compare($nailing, \*NN);
die "$self: compare $nailing and $nailed: $!" if $diff<0;
} else {
$!==ENOENT or die "$self: check previous $nailed: $!\n";
$diff = 1;
}
if ($diff) {
$use = $nailing;
$rm = $nailed;
} else {
$use = $nailed;
$rm = $nailing;
}
rename $use, $mf or die "$self: install nailed $use: $!\n";
unlink_or_enoent $rm or die "$self: remove old $rm: $!\n";
print STDERR "Nailed $mf\n" if $verbose>=3;
}
}
sub invoke () {
my $r = system @ARGV;
if (!$r) {
return 0;
} elsif ($r<0) {
print STDERR "$self: could not execute $ARGV[0]: $!\n";
return 127;
} elsif ($r & 0xff00) {
print STDERR "$self: $ARGV[0] failed (exit status $r)\n";
return $r >> 8;
} else {
print STDERR "$self: $ARGV[0] died due to signal! (wait status $r)\n";
return 125;
}
}
sub uninstall1 ($$) {
my ($mf, $enoentok) = @_;
my $unnailed = "$mf.unnailed";
rename $unnailed, $mf or ($enoentok && $!==ENOENT)
or die "$self: failed to restore: rename $unnailed back to $mf: $!\n";
}
sub uninstall () {
foreach my $mf (keys %manifests) {
my $nailed = nailed($mf);
link $mf, $nailed or die "$self: preserve (link) $mf as $nailed: $!\n";
uninstall1($mf,0);
}
}
while (@ARGV && $ARGV[0] =~ m/^-/) {
$_ = shift @ARGV;
last if m{^--$};
if (m{^-[^-]}) {
while (m{^-.}) {
if (s{^-v}{-}) {
$verbose++;
} elsif (s{^-q}{-}) {
$verbose=0;
} elsif (s{^-n}{-}) {
$noact++;
} elsif (s{^-D}{-}) {
$dump++;
} else {
die "$self: unknown short option(s) $_\n";
}
}
} else {
die "$self: unknown long option $_\n";
}
}
takelock();
readnail();
readorigs();
calculate();
if ($dump) {
eval '
use Data::Dumper;
print STDERR Dumper(\%manifests, \%packagemap);
' or die $@;
}
exit 0 if $noact;
$want_uninstall = 1;
makebackups();
install();
printf STDERR "$self: Nailed (%d manifests, %d packages)\n",
(scalar %manifests, scalar %packagemap)
if $verbose;
my $estatus = invoke();
uninstall();
$want_uninstall = 1;
print STDERR "$self: Unnailed.\n" if $verbose;
exit $estatus;