#!/usr/bin/env perl

use strict;
use warnings;
use 5.024;
use English;

# Only modules that are in the standard distribution for 5.24. The rests should
# be in the INIT block below.
use File::Basename 'dirname';
use File::Path 'make_path';
use File::Spec::Functions 'catfile';
use FindBin;
use Getopt::Long 'GetOptions';
use Pod::Usage 'pod2usage';

# This must be kept in sync with the version in lib/App/UpdateConfig.pm (the
# script cannot use that module as it must work as a standalone file).
our $VERSION = '1.00';

# With --help, prints the entire documentation, through perldoc when available.
sub print_usage {
  my ($is_help) = @_;
  pod2usage({
    -msg => "update_config: Automatic updates of a linux configuration.\n",
    -verbose => $is_help ? 2 : 0,
    -exitval => $is_help ? 0 : 2,
    -output => $is_help ? \*STDOUT : \*STDERR,
  });
}

my %flags;
my @orig_argv;

BEGIN {
  @orig_argv = @ARGV;
  GetOptions(
    \%flags, 'silent', 'diff', 'help', 'test', 'list',
    'root', 'no-root', 'export', 'dir=s', 'pack'
  ) or print_usage(0);
  print_usage(1) if $flags{help};
  print_usage(0) if @ARGV;
  if ($flags{pack} and $0 eq '-') {
    print STDERR "Cannot use --pack if the script is read from the standard input\n";
    exit 1;
  }
}

my $need_sudo = 0;

sub try_load {
  my ($m, @args) = @_;
  eval "require $m" or return 0;  ## no critic (ProhibitStringyEval)
  $m->import(@args);
  return 1;
}

my $has_local_lib = '';

sub load_module {
  my ($m, @args) = @_;
  return 1 if try_load($m, @args);

  # We try to load local::lib if we need to install a module.
  # If we don’t have local::lib, we won’t install it as that might require a
  # sudo and, at that point, that defeats the points of using local::lib in the
  # first place.
  if (!$has_local_lib) {
    # local::lib prints some configuration and exit the program when $0 is '-' (meant for `perl -Mlocal::lib`).
    local $0 = $0 eq '-' ? 'fakename.pl' : $0;
    if (try_load('local::lib')) {
      $has_local_lib = '-I';
      print "Successfully loaded local::lib\n" unless $flags{silent};
      # We try to load the module again, in case it was already installed locally.
      return 1 if try_load($m, @args);
    } else {
      $has_local_lib = ' ';  # true but useless in the command line below.
      print "Failed to load local::lib\n" unless $flags{silent};
    }
  }

  # Now, if we have set-up local::lib these will be installed locally otherwise
  # we try to install them system-wide, which might require the use of sudo.

  local $ENV{PERL_MM_USE_DEFAULT} = 1;  # Used so that cpan don’t ask questions.
  if (!$need_sudo) {
    system "cpan ${has_local_lib} -i $m" and $need_sudo = 1;
  }
  if ($need_sudo) {
    system "sudo cpan -i $m" and die "Cannot install module '$m'.\n";
  }
  try_load($m, @args) or die "Cannot load module '$m'.\n";
  return 1;
}

# We try to load and, if necessary, install non-standard modules.
INIT {
  load_module 'Data::Section::Simple', 'get_data_section';
  load_module 'File::HomeDir';
  load_module 'File::Slurp', 'read_file', 'write_file';
  load_module 'Text::Diff', 'diff';
  load_module 'File::Which';  # Loaded so that config fragments can REQUIRE which('program')
}

use constant DEFAULT_COMMENTS_CHAR => '#';
use constant DEFAULT_GUARD_STRING => 'AUTO-CONFIG';
use constant COMMENTS_CHAR_COUNT => 3;  # In the guard markers.

sub get_home_dir {
  return File::HomeDir->my_home
  # return `echo -n ~`;
}

# Returns the default directory of the configuration fragments: ~/.update_config
# if it exists, otherwise $XDG_CONFIG_HOME/update_config.
sub get_config_dir {
  my $home_config = catfile(get_home_dir(), '.update_config');
  return $home_config if -d $home_config;
  return catfile($ENV{XDG_CONFIG_HOME} || catfile(get_home_dir(), '.config'), 'update_config');
}

# Remove part of a file name that we are ignoring when creating the
# target file (for the moment, only a suffix within bracket).
sub clean_output_path {
  my ($name) = @_;
  return $name =~ s/\s*(?:\[.*\]\s*)$//r;
}
# parse_file_name($file_name)
# Returns a tuple (mode, input_spec, output_spec) where mode is one
# of 'file' or 'pipe' specifying if the input and output spec will
# be normal file name or a commands that should be executed.
# If the file has a prefix in bracket, then it is ignored.
sub parse_file_name {
  # if more logic is added in this function, it may be needed to reverse
  # it in the export block.
  my ($raw_path) = @_;
  $raw_path = clean_output_path($raw_path);
  my @file_part = split /,/, $raw_path;
  my $mode = @file_part == 1 ? 'file' : 'pipe';
  die "Invalid file specification: '$raw_path'.\n" if @file_part < 1 || @file_part > 2;
  if (@file_part == 1) {
    my $path;
    if ($file_part[0] =~ m{^/}) {
      $path = $file_part[0];
    } else {
      $path = catfile(get_home_dir(), $file_part[0]);
    }
    return ('file', $path, $path);
  } else {
    return ('pipe', @file_part);
  }
}

# Returns the current content of the target, split in three parts: the content
# before the guard markers, between them, and after them.
sub read_content {
  my ($mode, $file, $conf) = @_;
  if ($mode eq 'file' and not -e $file) {
    return ('', '', '');
  }
  open(my $fh, ($mode eq 'file' ? '<' : '-|'), $file) or die "Cannot open '$file' for read: $!.\n";
  my @lines = <$fh>;
  # Closing a pipe fails if the command fails, which is expected for some of
  # them (e.g. `crontab -l` when there is no crontab yet).
  close $fh or $mode eq 'pipe' or die "Cannot close '$file': $!.\n";

  return ('', join('', @lines), '') if $conf->{entire_file};
  my ($start) = grep { $lines[$_] eq $conf->{start_marker} } 0 .. $#lines;
  if (not defined $start) {
    return $conf->{is_prefix} ? ('', '', join('', @lines)) : (join('', @lines), '', '');
  }
  my ($end) = grep { $lines[$_] eq $conf->{end_marker} } $start + 1 .. $#lines;
  die "Missing closing tag in '$file'.\n" if not defined $end;
  return (
    join('', @lines[0 .. $start - 1]),
    join('', @lines[$start + 1 .. $end - 1]),
    join('', @lines[$end + 1 .. $#lines]));
}

sub write_content {
  my ($mode, $file, $content, $conf) = @_;
  if ($mode eq 'file') {
    my $dir = dirname($file);
    if (not -e $dir) {
      make_path($dir) or die "Cannot create directory '$dir': $!.\n";
    }
  }
  open(my $fh, ($mode eq 'file' ? '>' : '|-'), $file) or die "Cannot open '$file' for write: $!\n";
  print $fh $content;
  if ($conf->{make_executable}) {
    my $current_mode = (stat $fh)[2] & oct('7777');
    chmod($current_mode | oct('111'), $fh);
  }
  close $fh or die "Error writing '$file': $!.\n";
  chmod oct($conf->{perm}), $file if need_perm_update($file, $mode, $conf);
  return;
}

sub need_perm_update {
  my ($file, $mode, $conf) = @_;
  return 0 if not exists $conf->{perm};
  return 0 if $mode ne 'file';
  my $current = (stat $file)[2] & oct('7777');
  return $current != oct($conf->{perm});
}

# The directives that can appear at the beginning of a fragment. Each entry
# gives the key of the fragment configuration where the directive is stored
# (if any) and how: `flag` directives take no value and set their key to 1,
# `multiple` directives can be repeated and store their values in a list, the
# others store their value directly.
my %DIRECTIVES = (
  'COMMENTS CHAR' => {key => 'comments_char'},
  'ENTIRE FILE' => {key => 'entire_file', flag => 1},
  'FILENAME' => {key => 'filename'},
  'GUARD SUFFIX' => {key => 'guard_suffix'},
  'IS PREFIX' => {key => 'is_prefix', flag => 1},
  'MAKE EXECUTABLE' => {key => 'make_executable', flag => 1},
  'NEED ROOT' => {key => 'need_root', flag => 1},
  # TODO: validate that the mode is a correct octal value.
  'PERM' => {key => 'perm'},
  'POST UPDATE' => {key => 'post_update'},
  'REM' => {},
  'REQUIRE' => {key => 'require', multiple => 1},
);
my $DIRECTIVE_RE = join '|', map { quotemeta } sort keys %DIRECTIVES;

# Applies the directive in the given line to the fragment configuration.
# Returns false if the line is not a valid directive.
sub parse_directive {
  my ($line, $conf) = @_;
  my ($name, $value) = $line =~ m/^(${DIRECTIVE_RE}) (?: \s+ (\S.*?) )? \s*$/x or return 0;
  my $directive = $DIRECTIVES{$name};
  # Flag directives must not have a value and the other ones must have one.
  return 0 if $directive->{flag} ? defined $value : not defined $value;
  my $key = $directive->{key};
  if (not defined $key) {
    # Nothing to do, this is a comment.
  } elsif ($directive->{flag}) {
    $conf->{$key} = 1;
  } elsif ($directive->{multiple}) {
    push @{$conf->{$key}}, $value;
  } else {
    $conf->{$key} = $value;
  }
  return 1;
}

sub parse_file_conf {
  my ($file) = @_;
  my %conf;
  $file =~ s/\n{2,}$/\n/;
  $file =~ s/^\n+//;
  # Each directive is on its own line, they can be followed by empty lines.
  while ($file =~ m/\A ([^\n]*) \n+/x) {
    my ($line, $end) = ($1, $LAST_MATCH_END[0]);
    last if not parse_directive($line, \%conf);
    substr $file, 0, $end, '';
  }
  my $comments_decorator = ($conf{comments_char} // DEFAULT_COMMENTS_CHAR) x COMMENTS_CHAR_COUNT;
  my $guard = DEFAULT_GUARD_STRING.(exists $conf{guard_suffix} ? ':'.$conf{guard_suffix} : '');
  $conf{start_marker} = $comments_decorator.$guard.' START'.$comments_decorator."\n";
  $conf{end_marker} = $comments_decorator.$guard.' END'.$comments_decorator."\n";
  $conf{content} = $file;
  return %conf;
}

# Puts in %$content the content of the files in the given directory and
# all its subdirectories. Ignores hidden files and directories. Ignores
# multiple files with the same name.
sub read_config_files {
  my ($dir, $content) = @_;
  opendir(my $dh, $dir) or die "Can't open dir '$dir': $!\n";
  while (readdir $dh) {
    next if m/^\./;
    my $f = catfile($dir, $_);
    read_config_files($f, $content) if -d $f;
    $content->{$_} = read_file($f) if -f $f;
  }
  closedir $dh;
  return;
}

# Writes in the current directory the fragments embedded in the script.
sub export_fragments {
  my $internal_files = get_data_section();
  while (my ($file, $content) = each %{$internal_files}) {
    my %conf = parse_file_conf($content);
    if (not exists $conf{filename}) {
      my $output = clean_output_path($file);
      $content = "FILENAME $output\n$content";
    }
    $file =~ s/^\.//;
    $file =~ s{/|,}{_}g;
    print "Exporting: $file\n";
    write_file($file, $content) or die "Cannot write file '$file': $!\n";
  }
  return;
}

# Prints on STDOUT our own script, followed by all the given fragments, so that
# they are embedded in its __DATA__ section.
sub pack_fragments {
  my ($config_files) = @_;
  print read_file(catfile($FindBin::RealBin, $FindBin::RealScript));
  for my $file (sort { (lc $a) cmp (lc $b) } keys %{$config_files}) {
    my $content = $config_files->{$file};
    # The next "@@" header must start on its own line.
    $content .= "\n" if $content ne '' and $content !~ m/\n\z/;
    print "@@ ${file}\n${content}";
  }
  return;
}

# Returns true if all the REQUIRE guards of the fragment are verified.
sub check_requirements {
  my ($conf, $display_name) = @_;
  for my $r (@{$conf->{require}}) {
    my ($expr, $reason) = split /\s*#\s*/, $r, 2;
    next if eval $expr;  ## no critic (ProhibitStringyEval)
    die "Error while executing 'require' guard for ${display_name} '${expr}': $@.\n" if $@;
    printf "Skipping %s due to require guard%s\n", $display_name, ($reason ? ': '.$reason : '')
        unless $flags{silent};
    return 0;
  }
  return 1;
}

# Writes the new content of the target file and executes the POST UPDATE
# command if any.
sub update_target {
  my ($mode, $out_path, $before, $after, $conf) = @_;
  my $content;
  if ($conf->{entire_file}) {
    $content = $conf->{content};
  } else {
    $content = $before.$conf->{start_marker}.$conf->{content}.$conf->{end_marker}.$after;
  }
  write_content($mode, $out_path, $content, $conf);
  if ($conf->{post_update}) {
    my $cmd = $conf->{post_update} =~ s/\$@/$out_path/gr;
    system $cmd;
  }
  return;
}

# Applies the given fragment (depending on the command line flags). Returns
# true if the fragment needs root and was not applied.
sub apply_fragment {
  my ($file, $content) = @_;
  my %conf = parse_file_conf($content);
  my $target = $conf{filename} // $file;
  my $display_name = $target.($conf{guard_suffix} ? ' ('.$conf{guard_suffix}.')' : '');
  return 0 if not check_requirements(\%conf, $display_name);
  my ($mode, $in_path, $out_path) = parse_file_name($target);
  if ($flags{list}) {
    print "$in_path\n";
    return 0;
  }
  my ($before, $old_content, $after) = read_content($mode, $in_path, \%conf);
  if ($old_content eq $conf{content} and not need_perm_update($out_path, $mode, \%conf)) {
    print "Nothing to do for: $display_name\n" unless $flags{silent};
    return 0;
  }
  if ($flags{diff}) {
    my $diff = diff(\$old_content, \$conf{content}, {CONTEXT => 0});
    print "Diff for: $display_name\n$diff";
  }
  return 1 if $conf{need_root} and not $flags{root};
  return 0 if $flags{root} and not $conf{need_root};
  update_target($mode, $out_path, $before, $after, \%conf) if not $flags{test};
  print "Updated: ${display_name}\n" unless $flags{silent};
  return 0;
}

sub main {
  if ($flags{export}) {
    export_fragments();
    return;
  }

  my $config_files = {};
  $config_files = get_data_section() unless $flags{pack};  # We don’t read __DATA__ if we’re packing content anyway.
  my $config_dir = $flags{dir} // get_config_dir();
  print "Reading configuration from: ${config_dir}\n" unless $flags{silent} or $flags{pack};
  read_config_files($config_dir, $config_files) if -d $config_dir;

  if ($flags{pack}) {
    pack_fragments($config_files);
    return;
  }

  my $need_root = 0;
  for my $file (sort { (lc $a) cmp (lc $b) } keys %{$config_files}) {
    $need_root = 1 if apply_fragment($file, $config_files->{$file});
  }

  return if not $need_root or $flags{'no-root'};
  if ($0 eq '-') {
    print "Skipping NEED_ROOT fragments for an execution from stdin\n" unless $flags{silent};
    return;
  }
  my $script = catfile(${FindBin::RealBin}, ${FindBin::RealScript});
  system('sudo', $script, @orig_argv, '--root');
  return;
}

main();

=pod

=encoding utf8

=head1 NAME

update_config - Deploy configuration fragments (dotfiles, etc.) locally or on
remote hosts.

=head1 SYNOPSIS

update_config [--test] [--help] [--diff] [--silent] [--list] [--dir directory]
[--root|--no-root] [--export] [--pack]

=head1 DESCRIPTION

The program reads configuration fragments from the F<~/.update_config>
directory if it exists. Otherwise, it reads them from the
F<$XDG_CONFIG_HOME/update_config> directory (F<~/.config/update_config> when
C<XDG_CONFIG_HOME> is not set). In both cases, all the subdirectories are read
too, as well as the fragments embedded in the script itself by the C<--pack>
option. A fragment
from the directory replaces an embedded fragment with the same name.

=head1 OPTIONS

The available options for the program are the following. They can all be
abbreviated down to a single character.

  --diff   Print the difference between the current configuration and what
           will be written

  --silent Do not print the status of the configuration files (except for
           error messages).

  --test   Do not modify the configuration files.

  --list   Only print a list of the configuration files and exit.

  --root   Install only the configuration fragments that are marked as
           'NEED ROOT'.

  --no-root  Do not attempt to install the 'NEED ROOT' fragments.

  --export Export in the current directory all the files that are embedded
           in the script.

  --dir directory   Process only the configuration files in the given
           directory and its subdirectories, instead of those from the
           default path.

  --pack  Write on the standard output a version of the script where all the
          config fragments are embedded. To be used typically with:
            update_config --pack | ssh user@host perl -- - --no-root
          or just
            update_config --pack | ssh host perl

  --help   Print this help message.

=head1 FRAGMENT FILES

Each fragment file describes a piece of content that should be present in a
target file. By default, the target is a file directly in your home directory,
with the same name as the fragment. However, hidden files are ignored when the
fragments are read, so most of the time you will set the target explicitly with
the C<FILENAME> directive described below (e.g. to update your F<.bashrc>).

You can organize the fragments in sub-directories, but these are not part of
the target path. Only the base name of a fragment is used, so two fragments
must not have the same name, even in different directories. To have several
fragments for the same file, give them distinct names with a suffix between
brackets (e.g. F<bashrc [linux]> and F<bashrc [macos]>, both with
C<FILENAME .bashrc>). That suffix is ignored if the name of the fragment is used
as the target. Hidden directories are ignored too and fragments are processed
in alphabetical order, ignoring case.

The content of the fragment is written in the target file between two guard
lines, which look like C<###AUTO-CONFIG START###> and C<###AUTO-CONFIG END###>.
Everything outside of these guards is left untouched, so you can still edit the
rest of the file by hand. If the guards are not already present, the content is
added at the end of the file, which is created if needed. When the guarded
content is already up to date, the file is not modified at all.

=head2 Directives

A fragment can start with a few directives, one per line, that control how it
is applied. The content of the fragment starts at the first line that is not a
directive, and the empty lines following the directives are skipped. The
supported directives are the following:

=over 4

=item C<FILENAME> I<path>

Sets the target file, instead of using the name of the fragment. The path is
relative to your home directory, unless it is an absolute path. The path can
also be made of two commands separated by a comma. In that case, the current
content is read from the output of the first command and the new content is
passed on the input of the second one (this is useful for C<crontab -l,
crontab ->).

=item C<COMMENTS CHAR> I<char>

Sets the character that starts a comment in the target file, which is used in
the guard lines (it is repeated three times). The default is C<#>.

=item C<GUARD SUFFIX> I<suffix>

Adds a suffix to the guard lines, which then look like
C<###AUTO-CONFIG:suffix START###>. You need this if several fragments target
the same file.

=item C<IS PREFIX>

Adds the content at the beginning of the file instead of at the end, when the
guards are not already present.

=item C<ENTIRE FILE>

Replaces the entire target file with the content of the fragment, without any
guard lines.

=item C<MAKE EXECUTABLE>

Makes the target file executable.

=item C<PERM> I<mode>

Sets the permissions of the target file, given in octal (e.g. C<600>).

=item C<NEED ROOT>

Marks a fragment that must be written as root (typically a file under
F</etc>). These fragments are applied at the end of the run, by executing the
program again through C<sudo> with the C<--root> option.

=item C<REQUIRE> I<expression> [C<#> I<reason>]

Evaluates a Perl expression and skips the fragment if it is false. The optional
reason is printed when the fragment is skipped. The expression can use the
C<which> function from L<File::Which> as well as the variables from
L<English>. This directive can be repeated, in which case all the expressions
must be true.

=item C<POST UPDATE> I<command>

Executes a shell command after the target file has been updated. In the
command, C<$@> is replaced by the path of the target file.

=item C<REM> I<text>

A comment, which is ignored.

=back

=head2 Examples

This fragment adds some content to your F<~/.bashrc> file, but only on WSL
hosts. The guard suffix allows to have another fragment for the same file:

  FILENAME .bashrc
  GUARD SUFFIX WSL
  REQUIRE `uname -r` =~ /WSL/ # Not a WSL host

  export BROWSER=wslview

This one installs a full script in a system directory, and needs root to do so:

  FILENAME /etc/network/if-pre-up.d/10-iptables-load
  REQUIRE -d '/etc/network/if-pre-up.d' # No if-pre-up.d directory
  NEED ROOT
  ENTIRE FILE
  MAKE EXECUTABLE

  #!/bin/sh
  iptables-restore < /etc/iptables.rules

And this one updates a configuration file and then reloads it in the running
program:

  FILENAME .tmux.conf
  REQUIRE which('tmux') # tmux is not installed
  POST UPDATE tmux source-file $@

  set -g prefix C-a

=cut

__DATA__
