#!/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 Config;
use Cwd ();
use Digest::SHA 'sha1_hex';
use File::Basename qw(basename dirname);
use File::Path 'make_path';
use File::Spec;
use File::Spec::Functions 'catfile';
use FindBin;
use Getopt::Long 'GetOptions';
use List::Util qw(all any first);
use Pod::Usage 'pod2usage';
use Scalar::Util 'refaddr';

# 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.04';

# 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', 'force'
  ) 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;
}

# Returns the full path of the given program if it is found in the PATH, or
# undef otherwise.
sub find_program {
  my ($name) = @_;
  return first { -f && -x } map { catfile($_, $name) } File::Spec->path();
}

# Returns true if this script is installed in one of the bin directories of
# the Perl installation (e.g. with `sudo cpanm`), rather than with local::lib or
# as a standalone copy.
sub is_installed_globally {
  return 0 if $0 eq '-';
  my @dirs =
      grep { defined && $_ ne '' }
      @Config{
    qw(installbin installscript installsitebin installsitescript installvendorbin installvendorscript)
      };
  return any { (Cwd::realpath($_) // '') eq $FindBin::RealBin } @dirs;
}

# Whether local::lib is loaded (undef until we try to load it).
my $has_local_lib;

# Installs the given module with cpanm if it is available, or cpan otherwise.
# The module is installed in the local::lib directory if local::lib is loaded,
# or system-wide otherwise, using sudo when needed.
sub install_module {
  my ($m) = @_;
  local $ENV{PERL_MM_USE_DEFAULT} = 1;  # Used so that cpan don’t ask questions.
  my $cpanm = find_program('cpanm');
  # When it can't write in the system directories, cpanm installs the modules
  # in ~/perl5, where we would not find them without local::lib. And when we
  # are installed globally, our modules must be installed globally too.
  $need_sudo = 1
      if ($cpanm or is_installed_globally())
      and not $has_local_lib
      and not -w $Config{installsitelib}
      and $EUID != 0;
  my @cmd = $cpanm ? ($cpanm) : ('cpan', ($has_local_lib ? '-I' : ()), '-i');
  my $name = $cpanm ? 'cpanm' : 'cpan';
  if (!$need_sudo) {
    print "Installing module '${m}' with ${name}\n" unless $flags{silent};
    return if system(@cmd, $m) == 0;
    $need_sudo = 1;
  }
  # sudo resets the environment, so the module is installed system-wide even
  # if local::lib is loaded.
  print "Installing module '${m}' with sudo ${name}\n" unless $flags{silent};
  system('sudo', ($cpanm ? $cpanm : qw(cpan -i)), $m) == 0
      or die "Cannot install module '$m'.\n";
  return;
}

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 (unless we are
  # installed globally, in which case the modules are installed alongside us).
  # 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 (not defined $has_local_lib and is_installed_globally()) {
    $has_local_lib = 0;
    print "Installing modules globally, as update_config is installed globally\n"
        unless $flags{silent};
  } elsif (!defined $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;
    $has_local_lib = try_load('local::lib');
    if ($has_local_lib) {
      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 {
      print "Failed to load local::lib\n" unless $flags{silent};
    }
  }

  install_module($m);
  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.
use constant ARRAYS_MARKER => 'update_config_arrays';  # In MERGE fragments.
use constant STATE_HASH_LENGTH => 16;  # Hex digits in the name of the saved states.
use constant ENTIRE_FILE_STATE_HEADER => "ENTIRE FILE\n\n";  # In the ENTIRE FILE states.
use constant DIR_CONF_NAME => '.update_config';  # The directives of a directory.

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;
}

# Returns the number of components in the given fragment name (its path relative
# to the configuration directory), which is the depth at which its own
# directives are set (see add_conf).
sub get_name_depth {
  my ($name) = @_;
  my @parts = split m{/}, $name;
  return scalar @parts;
}

# Returns the guard suffix of the fragment with the given name (its path
# relative to the configuration directory) and configuration (from
# parse_file_conf): its GUARD SUFFIX directive, if any, followed by the
# suffixes between brackets at the end of the names of the directories below
# the one where that directive is set and of the fragment itself (so all of
# them without the directive), joined with '-' and in upper case. Returns undef
# if there are no such suffixes.
sub get_guard_suffix {
  my ($name, $conf) = @_;
  my @parts = split m{/}, $name;
  my $from = exists $conf->{guard_suffix} ? $conf->{depth}{guard_suffix} : 0;
  my @suffixes =
      grep { defined && $_ ne '' } map { m/\s*\[(.*)\]\s*$/ ? $1 : undef } @parts[$from .. $#parts];
  unshift @suffixes, $conf->{guard_suffix} if exists $conf->{guard_suffix};
  return @suffixes ? uc join('-', @suffixes) : undef;
}

# 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} or $conf->{merge};
  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 their
# `value` (default to 1),
# `multiple` directives can be repeated and store their values in a list, the
# others store their value directly (an empty string for `optional` directives
# without a value).
my %DIRECTIVES = (
  'BASE' => {key => 'base', multiple => 1},
  'COMMENTS CHAR' => {key => 'comments_char'},
  'DIR' => {key => 'dir'},
  '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},
  'MERGE' => {key => 'merge', optional => 1},
  'MERGE ARRAYS' => {key => 'merge_arrays'},
  # Both MIRROR variants set the same key, so that the deepest one wins.
  'MIRROR' => {key => 'mirror', flag => 1, value => 'dir'},
  'MIRROR CONTENTS' => {key => 'mirror', flag => 1, value => 'contents'},
  '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},
);
# Longest names first, so that a directive is not matched by its prefix (e.g.
# MERGE ARRAYS by MERGE).
my $DIRECTIVE_RE = join '|', map { quotemeta } sort { length $b <=> length $a } 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
  # (unless it is optional).
  return 0 if $directive->{flag} ? defined $value : !defined $value && !$directive->{optional};
  $value //= '';
  my $key = $directive->{key};
  if (not defined $key) {
    # Nothing to do, this is a comment.
  } elsif ($directive->{flag}) {
    $conf->{$key} = $directive->{value} // 1;
  } elsif ($directive->{multiple}) {
    push @{$conf->{$key}}, $value;
  } else {
    $conf->{$key} = $value;
  }
  return 1;
}

# Parses the directives at the beginning of the given fragment text. Returns a
# hash-ref with their values (see parse_directive), the rest of the text (the
# content of the fragment) and an array-ref of the lines of the directives.
sub parse_directives {
  my ($text) = @_;
  my (%conf, @lines);
  $text =~ s/\n{2,}$/\n/;
  $text =~ s/^\n+//;
  # Each directive is on its own line, they can be followed by empty lines.
  while ($text =~ m/\A ([^\n]*) \n+/x) {
    my ($line, $end) = ($1, $LAST_MATCH_END[0]);
    last if not parse_directive($line, \%conf);
    push @lines, $line;
    substr $text, 0, $end, '';
  }
  return (\%conf, $text, \@lines);
}

# Returns the directives of a DIR_CONF_NAME file with the given name (used in
# error messages), as a hash-ref (see parse_directive). Dies if the file
# contains anything else than directives and empty lines.
sub parse_dir_conf {
  my ($name, $text) = @_;
  my %conf;
  for my $line (split /\n/, $text) {
    next if $line !~ m/\S/;
    parse_directive($line, \%conf) or die "Invalid directive in '${name}': '${line}'.\n";
  }
  check_dir_and_mirror(\%conf, $name);
  return \%conf;
}

# Dies if the given directives (from parse_directive) of the file with the
# given name contain both DIR and MIRROR.
sub check_dir_and_mirror {
  my ($conf, $name) = @_;
  die "DIR and MIRROR cannot be used together in '${name}'.\n"
      if exists $conf->{dir} and exists $conf->{mirror};
  return;
}

# Adds to the combined configuration $conf the directives of $new (from
# parse_directive), which are set at the given depth: the number of
# directories between the root of the configuration directory and the
# DIR_CONF_NAME file setting them (or get_name_depth for the own directives of
# a fragment). The repeatable directives are appended to the existing ones,
# the others replace them. The depth of each directive is stored in the
# `depth` hash-ref of $conf.
sub add_conf {
  my ($conf, $new, $depth) = @_;
  # DIR and MIRROR both set the directory of the target, the deepest one wins.
  delete $conf->{mirror} if exists $new->{dir};
  delete $conf->{dir} if exists $new->{mirror};
  for my $key (keys %{$new}) {
    if (ref $new->{$key} eq 'ARRAY') {
      push @{$conf->{$key}}, @{$new->{$key}};
    } else {
      $conf->{$key} = $new->{$key};
    }
    $conf->{depth}{$key} = $depth;
  }
  return;
}

# Returns the configuration that the fragment with the given name inherits
# from the DIR_CONF_NAME files of its directories (from $dir_confs, see
# split_config_files), combined from the outermost one with add_conf.
sub get_inherited_conf {
  my ($name, $dir_confs) = @_;
  my @dirs = split m{/}, $name;
  pop @dirs;
  my %conf = (depth => {});
  for my $depth (0 .. @dirs) {
    my $dir_conf = $dir_confs->{join '/', @dirs[0 .. $depth - 1]};
    add_conf(\%conf, $dir_conf, $depth) if $dir_conf;
  }
  return \%conf;
}

# Returns the configuration of a fragment, as a hash with the values of its
# directives, its `content` and its guard markers. When the optional $name of
# the fragment is given, it is used for the defaults of some directives (see
# get_guard_suffix), and the fragment inherits the directives of its
# directories from the optional $dir_confs (see get_inherited_conf).
sub parse_file_conf {
  my ($file, $name, $dir_confs) = @_;
  my ($own, $content) = parse_directives($file);
  check_dir_and_mirror($own, $name // 'the fragment');
  my %conf = defined $name ? %{get_inherited_conf($name, $dir_confs // {})} : (depth => {});
  add_conf(\%conf, $own, defined $name ? get_name_depth($name) : 0);
  # MERGE ARRAYS can be set in a directory for its fragments that use MERGE,
  # and COMMENTS CHAR for its fragments that don't (unless it is set as deep
  # as MERGE).
  delete $conf{merge_arrays} if not exists $conf{merge} and not exists $own->{merge_arrays};
  delete $conf{comments_char}
      if exists $conf{merge}
      and exists $conf{comments_char}
      and $conf{depth}{comments_char} < $conf{depth}{merge};
  if (defined $name and defined $conf{merge} and $conf{merge} eq '') {
    $conf{merge} = get_merge_format($name, get_target($name, \%conf));
  }
  if (defined $name) {
    my $suffix = get_guard_suffix($name, \%conf);
    $conf{guard_suffix} = $suffix if defined $suffix;
  } elsif (exists $conf{guard_suffix}) {
    $conf{guard_suffix} = uc $conf{guard_suffix};
  }
  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} = $content;
  validate_merge_conf(\%conf) if exists $conf{merge} or exists $conf{merge_arrays};
  return %conf;
}

# The formats supported by the MERGE directive. Each entry gives the module
# needed to handle the format (if any, it is loaded only when used), a `parse`
# function that takes a text and returns the corresponding data (dies on
# error), and a `serialize` function that takes a data hash-ref and returns its
# text representation (with sorted keys when possible).
my %MERGE_FORMATS = (
  ini => {
    module => 'Config::Tiny',
    parse => \&parse_ini,
    serialize => sub { Config::Tiny->new($_[0])->write_string },
  },
  json => {
    module => 'JSON::PP',
    parse => sub { $_[0] =~ m/\S/ ? JSON::PP->new->relaxed->decode($_[0]) : {} },
    serialize => sub {
      my $json = JSON::PP->new->canonical->indent;
      $json->space_after->indent_length(2);
      return $json->encode($_[0]);
    },
  },
  toml => {
    module => 'TOML::Tiny',
    parse => \&parse_toml,
    serialize => sub { my $t = TOML::Tiny::to_toml($_[0]); $t eq '' ? '' : "${t}\n" },
  },
  yaml => {
    module => 'YAML::PP',
    parse => \&parse_yaml,
    serialize => sub { YAML::PP->new(boolean => 'JSON::PP', header => 0)->dump_string($_[0]) },
  },
);

# The file extensions, other than the names of the MERGE formats, that are
# recognized by get_merge_format.
my %MERGE_EXTENSIONS = (yml => 'yaml');

# Returns the MERGE format of the fragment with the given name, from the
# extension of its target (ignoring the suffix between brackets). Dies if that
# extension is not a known format.
sub get_merge_format {
  my ($name, $target) = @_;
  my ($extension) = clean_output_path($target) =~ m/[.](\w+)$/;
  $extension = lc($extension // '');
  my $format = $MERGE_EXTENSIONS{$extension} // $extension;
  die "Cannot find the MERGE format of '${name}' from the extension of '${target}'.\n"
      if not exists $MERGE_FORMATS{$format};
  return $format;
}

# Dies if the MERGE directives of a fragment configuration are invalid and sets
# the default value of MERGE ARRAYS.
sub validate_merge_conf {
  my ($conf) = @_;
  die "MERGE ARRAYS requires the MERGE directive.\n" if not exists $conf->{merge};
  # Without a name, parse_file_conf does not know the target of the fragment,
  # from which the format would be found.
  die "Unsupported MERGE format: '$conf->{merge}'.\n"
      if $conf->{merge} ne '' and not exists $MERGE_FORMATS{lc $conf->{merge}};
  $conf->{merge} = lc $conf->{merge};
  $conf->{merge_arrays} //= 'auto';
  die "Invalid MERGE ARRAYS value: '$conf->{merge_arrays}'.\n"
      if not any { $conf->{merge_arrays} eq $_ } qw(auto union replace);
  for my $d ('COMMENTS CHAR', 'ENTIRE FILE', 'IS PREFIX') {
    die "MERGE cannot be used with ${d}.\n" if exists $conf->{$DIRECTIVES{$d}{key}};
  }
  return;
}

sub parse_toml {
  my ($text) = @_;
  my ($data, $error) = TOML::Tiny::from_toml($text);
  die "${error}\n" if $error;
  return $data;
}

sub parse_yaml {
  my ($text) = @_;
  my @docs = YAML::PP->new(boolean => 'JSON::PP')->load_string($text);
  die "Multiple YAML documents are not supported.\n" if @docs > 1;
  return $docs[0] // {};
}

# Returns the INI data as a plain hash-ref, where the keys outside of any
# section are in the `_` section.
sub parse_ini {
  my ($text) = @_;
  my $config = Config::Tiny->read_string($text) // die Config::Tiny->errstr."\n";
  return {%{$config}};
}

# Returns the hash-ref parsed from the given text in the given MERGE format.
# The $source is used in error messages.
sub parse_merge_data {
  my ($format, $text, $source) = @_;
  my $data = eval { $MERGE_FORMATS{$format}{parse}->($text) };
  if ($EVAL_ERROR) {
    my $error = $EVAL_ERROR =~ s/\s+\z//r;
    die "Cannot parse ${source} as ${format}: ${error}\n";
  }
  die "The content of ${source} is not a ${format} table.\n" if ref $data ne 'HASH';
  return $data;
}

# Returns true if the two given data structures are equal. Scalar values are
# compared as strings.
sub data_equal {
  my ($x, $y) = @_;
  return 0 if ref $x ne ref $y;
  if (ref $x eq 'HASH') {
    return 0 if keys %{$x} != keys %{$y};
    return all { exists $y->{$_} and data_equal($x->{$_}, $y->{$_}) } keys %{$x};
  }
  if (ref $x eq 'ARRAY') {
    return 0 if @{$x} != @{$y};
    return all { data_equal($x->[$_], $y->[$_]) } 0 .. $#{$x};
  }
  return !defined $y if !defined $x;
  return defined $y && "$x" eq "$y";
}

# Removes recursively the ARRAYS_MARKER entries from the given fragment data and
# records in %$modes the merge mode of the arrays that they name (see
# parse_array_mode), indexed by the address of these arrays.
sub extract_array_modes {
  my ($data, $modes) = @_;
  if (ref $data eq 'HASH') {
    my $marker = delete $data->{+ARRAYS_MARKER} // {};
    die ARRAYS_MARKER." must be a map.\n" if ref $marker ne 'HASH';
    for my $k (keys %{$marker}) {
      die ARRAYS_MARKER." names '${k}' which is not an array.\n" if ref $data->{$k} ne 'ARRAY';
      $modes->{refaddr $data->{$k}} = parse_array_mode($marker->{$k});
    }
    extract_array_modes($_, $modes) for values %{$data};
  } elsif (ref $data eq 'ARRAY') {
    extract_array_modes($_, $modes) for @{$data};
  }
  return;
}

# Returns the merge mode described by the given text: `union`, `replace` or
# an array-ref of the key fields given as `key:field1,field2`.
sub parse_array_mode {
  my ($text) = @_;
  die "Invalid array merge mode: '${text}'.\n" if ref $text;
  return $text if any { $text eq $_ } qw(union replace);
  if ($text =~ m/^key:(.+)$/) {
    return [split /,/, $1];
  }
  die "Invalid array merge mode: '${text}'.\n";
}

# Returns the merge mode of the given fragment $array, to be merged into the
# $target array. Arrays without an explicit mode use the MERGE ARRAYS directive
# and, by default, are replaced if they contain only scalars.
sub get_array_mode {
  my ($ctx, $array, $target) = @_;
  my $mode = $ctx->{modes}{refaddr $array} // $ctx->{default};
  return $mode if $mode ne 'auto';
  return (any { ref } @{$array}, @{$target}) ? 'union' : 'replace';
}

# Merges in place the $new hash-ref (from a fragment) into the $target one
# (from the target file). $old is the data of the previous version of the
# fragment (or an empty hash-ref), its values that are no longer in $new are
# removed from $target, unless they were modified there. Nested hashes are
# merged recursively and arrays according to their mode (see get_array_mode).
# $ctx has the `modes` from extract_array_modes and the `default` mode.
sub merge_hash {
  my ($target, $old, $new, $ctx) = @_;
  for my $k (keys %{$new}) {
    my ($t, $o, $n) = ($target->{$k}, $old->{$k}, $new->{$k});
    my $mode;
    if (ref $n eq 'HASH' and ref $t eq 'HASH') {
      merge_hash($t, ref $o eq 'HASH' ? $o : {}, $n, $ctx);
    } elsif (ref $n eq 'ARRAY'
      and ref $t eq 'ARRAY'
      and ($mode = get_array_mode($ctx, $n, $t)) ne 'replace') {
      merge_array($t, ref $o eq 'ARRAY' ? $o : [], $n, $mode, $ctx);
    } else {
      $target->{$k} = $n;
    }
  }
  for my $k (grep { !exists $new->{$_} && exists $target->{$_} } keys %{$old}) {
    my ($t, $o) = ($target->{$k}, $old->{$k});
    my $mode;
    if (ref $o eq 'HASH' and ref $t eq 'HASH') {
      merge_hash($t, $o, {}, $ctx);
      delete $target->{$k} if not %{$t};
    } elsif (ref $o eq 'ARRAY'
      and ref $t eq 'ARRAY'
      and ($mode = get_array_mode($ctx, $o, $t)) ne 'replace') {
      merge_array($t, $o, [], $mode, $ctx);
      delete $target->{$k} if not @{$t};
    } elsif (data_equal($t, $o)) {
      delete $target->{$k};
    }
  }
  return;
}

# Merges in place the $new array-ref into $target, with the given mode (`union`
# or the array-ref of key fields), see merge_hash.
sub merge_array {
  my ($target, $old, $new, $mode, $ctx) = @_;
  return merge_keyed_array($target, $old, $new, $mode, $ctx) if ref $mode;
  my @removed = grep {
    my $o = $_;
    !any { data_equal($o, $_) } @{$new}
  } @{$old};
  @{$target} = grep {
    my $t = $_;
    !any { data_equal($t, $_) } @removed
  } @{$target};
  push @{$target}, grep {
    my $n = $_;
    !any { data_equal($n, $_) } @{$target}
  } @{$new};
  return;
}

# Merges in place arrays of maps identified by the given key fields: the
# entries of $target with the same key as an entry of $new are merged with it
# (with merge_hash), the others from $new are appended. The values of the
# entries removed since $old are removed, as well as these entries if only
# their key remains.
sub merge_keyed_array {
  my ($target, $old, $new, $fields, $ctx) = @_;
  # Returns the key of an entry or undef if it does not have all the fields.
  my $key_of = sub {
    my ($e) = @_;
    return if ref $e ne 'HASH' or any { !defined $e->{$_} || ref $e->{$_} } @{$fields};
    return join "\0", map { $e->{$_} } @{$fields};
  };
  my (%new, %old, %seen);
  for my $n (@{$new}) {
    my $k = $key_of->($n) // die "An array entry is missing the key fields: @{$fields}.\n";
    die "Duplicate array entry for the key fields: @{$fields}.\n" if exists $new{$k};
    $new{$k} = $n;
  }
  for my $o (@{$old}) {
    my $k = $key_of->($o);
    $old{$k} = {%{$o}} if defined $k;
    delete @{$old{$k}}{@{$fields}} if defined $k;
  }
  my @result;
  for my $t (@{$target}) {
    my $k = $key_of->($t);
    if (defined $k and exists $new{$k}) {
      merge_hash($t, $old{$k} // {}, $new{$k}, $ctx);
      $seen{$k} = 1;
    } elsif (defined $k and exists $old{$k}) {
      merge_hash($t, $old{$k}, {}, $ctx);
      next if keys %{$t} == @{$fields};
    }
    push @result, $t;
  }
  push @result, grep { !$seen{$key_of->($_)} } @{$new};
  @{$target} = @result;
  return;
}

# Returns the path of the file where the last applied version of the given
# MERGE or ENTIRE FILE fragment (from prepare_fragment) is saved, which is
# specific to the fragment (its path in the configuration directory) and to its
# target. The NEED ROOT fragments are saved in a system directory so that the
# state of the user is never written by root.
sub get_state_path {
  my ($fragment) = @_;
  my ($name, $in_path, $conf) = @{$fragment}{qw(name in_path conf)};
  my $dir;
  if ($conf->{need_root}) {
    $dir = $ENV{UPDATE_CONFIG_ROOT_STATE_DIR} || '/var/lib/update_config';
  } else {
    $dir = catfile($ENV{XDG_STATE_HOME} || catfile(get_home_dir(), '.local', 'state'),
      'update_config');
  }
  # The readable part of the name is not unique (in particular for commands),
  # so we add a hash of the full target and of the name of the fragment.
  my $readable = basename($in_path) =~ s/[^\w.]+/_/gr;
  my $hash = substr sha1_hex(join "\0", $in_path, $name), 0, STATE_HASH_LENGTH;
  return catfile($dir, "${readable}-${hash}");
}

# Returns the data of the previous version of the given MERGE fragment (from
# prepare_fragment), if it was saved with the same format. Otherwise returns an
# empty hash-ref.
sub read_merge_state {
  my ($fragment) = @_;
  my $conf = $fragment->{conf};
  my $path = get_state_path($fragment);
  return {} if not -f $path;
  my %old = parse_file_conf(scalar read_file($path));
  return {} if ($old{merge} // '') ne $conf->{merge};
  return parse_merge_data($old{merge}, $old{content}, "the saved state '${path}'");
}

# Returns the content of the given ENTIRE FILE fragment (from prepare_fragment)
# when it was last applied, or undef if it was not saved.
sub read_entire_file_state {
  my ($fragment) = @_;
  my $path = get_state_path($fragment);
  return if not -f $path;
  my $content = read_file($path);
  return if substr($content, 0, length ENTIRE_FILE_STATE_HEADER) ne ENTIRE_FILE_STATE_HEADER;
  return substr $content, length ENTIRE_FILE_STATE_HEADER;
}

# Saves the content of the given MERGE (with its format) or ENTIRE FILE
# fragment (from prepare_fragment), so that it can be read by read_merge_state
# or read_entire_file_state on the next run.
sub save_state {
  my ($fragment) = @_;
  my $conf = $fragment->{conf};
  my $path = get_state_path($fragment);
  my $header = $conf->{merge} ? "MERGE $conf->{merge}\n\n" : ENTIRE_FILE_STATE_HEADER;
  my $content = $header.$conf->{content};
  return if -f $path and read_file($path) eq $content;
  my $dir = dirname($path);
  make_path($dir) if not -d $dir;
  write_file($path, $content) or die "Cannot write '${path}': $!\n";
  return;
}

# Returns the current content of a MERGE target, re-serialized in its format,
# and its content once the fragment is merged into it.
sub merge_content {
  my ($mode, $file, $conf, $old) = @_;
  my (undef, $text) = read_content($mode, $file, $conf);
  my $data = parse_merge_data($conf->{merge}, $text, "'${file}'");
  my $new = parse_merge_data($conf->{merge}, $conf->{content}, 'the fragment');
  my $ctx = {modes => {}, default => $conf->{merge_arrays}};
  extract_array_modes($_, $ctx->{modes}) for $new, $old;
  my $serialize = $MERGE_FORMATS{$conf->{merge}}{serialize};
  my $old_content = $serialize->($data);
  merge_hash($data, $old, $new, $ctx);
  return ($old_content, $serialize->($data));
}

# Puts in %$content the content of the files in the given directory and all its
# subdirectories, indexed by their path relative to the given directory (the
# optional $prefix is added at the beginning of these paths). Ignores hidden files and
# directories, except for the DIR_CONF_NAME files.
sub read_config_files {
  my ($dir, $content, $prefix) = @_;
  opendir(my $dh, $dir) or die "Can't open dir '$dir': $!\n";
  while (readdir $dh) {
    my $f = catfile($dir, $_);
    next if m/^\./ and ($_ ne DIR_CONF_NAME or not -f $f);
    my $name = defined $prefix ? "${prefix}/$_" : $_;
    read_config_files($f, $content, $name) if -d $f;
    $content->{$name} = read_file($f) if -f $f;
  }
  closedir $dh;
  return;
}

# Splits the given configuration files (indexed by their path relative to the
# configuration directory) into the fragments, indexed the same way, and the
# directives of the DIR_CONF_NAME files (from parse_dir_conf), indexed by the
# path of their directory ('' for the root of the configuration directory).
sub split_config_files {
  my ($config_files) = @_;
  my (%fragments, %dir_confs);
  while (my ($name, $content) = each %{$config_files}) {
    if (basename($name) eq DIR_CONF_NAME) {
      $dir_confs{$name =~ s{/?[^/]+$}{}r} = parse_dir_conf($name, $content);
    } else {
      $fragments{$name} = $content;
    }
  }
  return (\%fragments, \%dir_confs);
}

# The keys of the directives that are replaced by a single FILENAME directive
# in the exported fragments.
my %TARGET_KEYS = map { $_ => 1 } qw(base dir filename mirror);

# Returns the text of the given directive, with the given value.
sub format_directive {
  my ($directive, $value) = @_;
  return $DIRECTIVES{$directive}{flag} || $value eq '' ? $directive : "${directive} ${value}";
}

# Writes in the current directory the fragments embedded in the script. The
# exported files are not in their directories, so their target, their guard
# suffix and the directives inherited from their directories are written
# explicitly.
sub export_fragments {
  my ($fragments, $dir_confs) = split_config_files(get_data_section());
  for my $file (sort keys %{$fragments}) {
    my %conf = parse_file_conf($fragments->{$file}, $file, $dir_confs);
    my ($own, $content, $own_lines) = parse_directives($fragments->{$file});
    my $inherited = get_inherited_conf($file, $dir_confs);
    my @header = ('FILENAME '.get_target($file, \%conf));
    push @header, "GUARD SUFFIX $conf{guard_suffix}"
        if exists $conf{guard_suffix} and not exists $own->{guard_suffix};
    for my $d (sort keys %DIRECTIVES) {
      my ($key, $multiple) = @{$DIRECTIVES{$d}}{qw(key multiple)};
      next if not defined $key or $TARGET_KEYS{$key} or $key eq 'guard_suffix';
      next if not exists $inherited->{$key} or not exists $conf{$key};
      next if exists $own->{$key} and not $multiple;
      push @header,
          map { format_directive($d, $_) } $multiple ? @{$inherited->{$key}} : $inherited->{$key};
    }
    for my $line (@{$own_lines}) {
      my ($d) = $line =~ m/^(${DIRECTIVE_RE})/;
      push @header, $line if not $TARGET_KEYS{$DIRECTIVES{$d}{key} // ''};
    }
    $content = join('', map { "${_}\n" } @header).$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 by_fragment_order 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, $new_content, $after, $conf) = @_;
  my $content;
  if ($conf->{entire_file} or $conf->{merge}) {
    $content = $new_content;
  } else {
    $content = $before.$conf->{start_marker}.$new_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;
}

# Returns the current content of the target of the given fragment (from
# prepare_fragment), split in four parts: the content before the managed part,
# the current and new versions of the managed part, and the content after it.
sub get_contents {
  my ($fragment) = @_;
  my ($mode, $in_path, $conf) = @{$fragment}{qw(mode in_path conf)};
  if (not $conf->{merge}) {
    my ($before, $old_content, $after) = read_content($mode, $in_path, $conf);
    return ($before, $old_content, $conf->{content}, $after);
  }
  my $module = $MERGE_FORMATS{$conf->{merge}}{module};
  load_module($module) if $module;
  my $old = read_merge_state($fragment);
  return ('', merge_content($mode, $in_path, $conf, $old), '');
}

# Returns the given $path resolved relative to the $base path. Both are relative
# to the home directory (an empty $base is the home directory itself), unless
# they are absolute. A $path starting with `~` is relative to the home
# directory, whatever the $base.
sub resolve_path {
  my ($base, $path) = @_;
  return $path if $path =~ m{^/};
  if ($path =~ m{^~(?:/+(.*))?$}) {
    return $1 // '';
  }
  return $path if $base eq '';
  return catfile($base, $path);
}

# Returns the given component of the name of a fragment (its base name or, with
# the MIRROR directive, one of its directories), as it is used in its target:
# without its suffix between brackets and with a `dot_` prefix replaced by a
# dot (as hidden files are ignored in the configuration directory). $name is
# the name of the fragment, used in error messages.
sub get_target_name {
  my ($name, $part) = @_;
  my $clean = clean_output_path($part);
  die "Cannot use '${part}' in the target of '${name}', its name is only a guard suffix.\n"
      if $clean eq '';
  return $clean =~ s/^dot_/./r;
}

# Returns the directory of the target of the fragment with the given name and
# the MIRROR directive: the path of its directory relative to the parent of the
# directory where MIRROR is set (the one containing the DIR_CONF_NAME file, or
# the fragment itself), or relative to that directory with MIRROR CONTENTS. The
# root of the configuration directory is never part of that path (see
# get_target_name).
sub get_mirrored_dir {
  my ($name, $conf) = @_;
  my @dirs = split m{/}, $name;
  pop @dirs;
  # The own directives of a fragment are one level deeper than its directory.
  my $from = $conf->{depth}{mirror};
  $from = @dirs if $from > @dirs;
  $from-- if $conf->{mirror} eq 'dir' and $from > 0;
  return join '/', map { get_target_name($name, $_) } @dirs[$from .. $#dirs];
}

# Returns the target of the given fragment, from its BASE, DIR (or MIRROR) and
# FILENAME directives and from its name, in the format expected by
# parse_file_name. An absolute FILENAME (or one starting with `~` or made of
# commands) ignores the BASE, DIR and MIRROR directives set in a parent
# directory. Dies if these directives are incompatible.
sub get_target {
  my ($name, $conf) = @_;
  my $file = $conf->{filename} // get_target_name($name, basename($name));
  if ($file =~ m{^(?:/|~(?:/|$))} or $file =~ m/,/) {
    my $file_depth = exists $conf->{filename} ? $conf->{depth}{filename} : get_name_depth($name);
    for my $d ('DIR', 'MIRROR') {
      my $key = $DIRECTIVES{$d}{key};
      next if not exists $conf->{$key} or $conf->{depth}{$key} < $file_depth;
      die "${d} cannot be used with commands in '${name}'.\n" if $file =~ m/,/;
      die "FILENAME cannot be an absolute path with ${d} in '${name}'.\n";
    }
    return $file =~ m/,/ ? $file : resolve_path('', $file);
  }
  my $dir = exists $conf->{mirror} ? get_mirrored_dir($name, $conf) : $conf->{dir};
  my $target = '';
  $target = resolve_path($target, $_)
      for @{$conf->{base} // []}, grep { defined && $_ ne '' } $dir, $file;
  return $target;
}

# Sorts the fragments by their base name and then by their path, ignoring case.
sub by_fragment_order {
  return (lc basename($a) cmp lc basename($b)) || (lc $a cmp lc $b);
}

# Returns the description of the given fragment (from its name and content, and
# the directives of its directories, see parse_file_conf), as a hash-ref with
# its name, `conf` (from parse_file_conf), `display_name`, and the `mode`,
# `in_path` and `out_path` of its target (from parse_file_name). Returns undef
# if its REQUIRE guards are not verified.
sub prepare_fragment {
  my ($name, $content, $dir_confs) = @_;
  my %conf = parse_file_conf($content, $name, $dir_confs);
  my $target = get_target($name, \%conf);
  my $display_name = $target.($conf{guard_suffix} ? ' ('.$conf{guard_suffix}.')' : '');
  return if not check_requirements(\%conf, $display_name);
  my %fragment = (name => $name, conf => \%conf, display_name => $display_name);
  @fragment{qw(mode in_path out_path)} = parse_file_name($target);
  return \%fragment;
}

# Dies if some of the given fragments (from prepare_fragment) can't be applied
# to the same target: when they have the same guard suffix (unless they both
# use MERGE), when one of them uses ENTIRE FILE, or when only one of them uses
# MERGE.
sub check_conflicts {
  my (@fragments) = @_;
  my %by_target;
  for my $f (@fragments) {
    my $c = $f->{conf};
    for my $other (@{$by_target{"$f->{mode}\0$f->{in_path}"}}) {
      my $o = $other->{conf};
      next
          if !$c->{entire_file}
          && !$o->{entire_file}
          && !$c->{merge} == !$o->{merge}
          && ($c->{merge} || ($c->{guard_suffix} // "\0") ne ($o->{guard_suffix} // "\0"));
      die "Fragments '$other->{name}' and '$f->{name}' can't both be applied to "
          ."'$f->{in_path}', use different GUARD SUFFIX directives.\n";
    }
    push @{$by_target{"$f->{mode}\0$f->{in_path}"}}, $f;
  }
  return;
}

# Returns the modifications made to the target of the given ENTIRE FILE fragment
# (from prepare_fragment), whose current content is given, since the fragment
# was last applied (according to its saved state), as a diff. Returns undef if
# the target was not modified, or for the other fragments.
sub get_target_modifications {
  my ($fragment, $current) = @_;
  my ($conf, $mode, $in_path) = @{$fragment}{qw(conf mode in_path)};
  return if not $conf->{entire_file};
  return if $mode eq 'file' and not -e $in_path;
  my $saved = read_entire_file_state($fragment) // return;
  return if $saved eq $current;
  return diff(\$saved, \$current, {CONTEXT => 0});
}

# Checks whether the target of the given fragment (from prepare_fragment), whose
# current and new contents are given, can be overwritten (see
# get_target_modifications). Returns undef, after printing the modifications,
# if the fragment must be skipped. Otherwise, returns the text to add to the
# message reporting the update: ' (forced)' if the target was modified but
# --force is used, or an empty string.
sub check_target_modifications {
  my ($fragment, $current, $new) = @_;
  return '' if $current eq $new;
  my $modifications = get_target_modifications($fragment, $current) // return '';
  return ' (forced)' if $flags{force};
  print STDERR "Skipping $fragment->{display_name}, which was modified since its last update "
      ."(use --force to overwrite it):\n${modifications}";
  return;
}

# Applies the given fragment (from prepare_fragment), depending on the command
# line flags. Returns true if the fragment needs root and was not applied.
sub apply_fragment {
  my ($fragment) = @_;
  my ($conf, $display_name) = @{$fragment}{qw(conf display_name)};
  my ($mode, $in_path, $out_path) = @{$fragment}{qw(mode in_path out_path)};
  my ($before, $old_content, $new_content, $after) = get_contents($fragment);
  # Whether this run is the one that writes this fragment (as root or not).
  my $can_write = !$flags{test} && !$conf->{need_root} == !$flags{root};
  if ($old_content eq $new_content and not need_perm_update($out_path, $mode, $conf)) {
    print "Nothing to do for: $display_name\n" unless $flags{silent};
    save_state($fragment) if ($conf->{merge} or $conf->{entire_file}) and $can_write;
    return 0;
  }
  if ($flags{diff}) {
    my $diff = diff(\$old_content, \$new_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};
  my $forced = check_target_modifications($fragment, $old_content, $new_content) // return 0;
  if ($can_write) {
    update_target($mode, $out_path, $before, $new_content, $after, $conf);
    save_state($fragment) if $conf->{merge} or $conf->{entire_file};
  }
  print "Updated: ${display_name}${forced}\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 ($fragment_files, $dir_confs) = split_config_files($config_files);
  my @fragments = map { prepare_fragment($_, $fragment_files->{$_}, $dir_confs) }
      sort by_fragment_order keys %{$fragment_files};
  if ($flags{list}) {
    print "$_->{in_path}\n" for @fragments;
    return;
  }
  check_conflicts(@fragments);

  my $need_root = 0;
  for my $f (@fragments) {
    $need_root = 1 if apply_fragment($f);
  }

  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] [--force] [--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 directory can also contain a F<.update_config> file, with directives
that apply to all its fragments (see L</Directory directives>). A fragment
from the directory replaces an embedded fragment with the same name.

The non-core modules used by the program are installed automatically when
they are missing (some of them only when they are first needed), with
C<cpanm> if it is available, or C<cpan> otherwise. If the program is installed
in the directories of the Perl installation (e.g. with C<sudo cpanm>), the
modules are installed there too, using C<sudo> if needed. Otherwise, they are
installed with L<local::lib> if that module is available, or system-wide (using
C<sudo> if needed).

=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.

  --force  Overwrite the targets of the 'ENTIRE FILE' fragments even if they
           were modified since they were last written by the program. These
           targets are then reported as "Updated: target (forced)".

  --export Export in the current directory all the files that are embedded
           in the script, with their target and the directives that they
           inherit from their directories written explicitly.

  --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 a C<dot_> prefix in the name of a fragment is replaced
by a dot in its target (e.g. F<dot_bashrc> targets F<.bashrc>). The target can
also be set explicitly with the C<FILENAME> directive described below.

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 as its default
target (unless the C<MIRROR> directive is used). A suffix between brackets in
that name is not part of the target but it is the default guard suffix of the fragment (e.g. F<bashrc [linux]> and
F<bashrc [macos]> both target F<.bashrc>, with the C<LINUX> and C<MACOS> guard
suffixes, which are always in upper case). Several fragments can be applied to the same file only if they have
different guard suffixes (see the C<GUARD SUFFIX> directive) or if they all
use C<MERGE>, otherwise the program fails without applying any fragment.

Similarly, a suffix between brackets at the end of the name of a directory
(e.g. F<[linux]> or F<work [linux]>) is the default guard suffix of all the
fragments that it contains, including in its sub-directories. When several of
these suffixes apply to a fragment (from its directories or its own name),
they are joined with C<->, from the outermost one (e.g. the default guard
suffix of F<[linux]/shell [work]/bashrc [prompt]> is C<LINUX-WORK-PROMPT>). Hidden
directories are ignored too and fragments are processed in alphabetical order
of their base name, ignoring case.

Unless the C<MERGE> directive is used (see L</Merged files>), 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 the directory given by C<DIR> or C<MIRROR> if any, itself relative
to the base directory (your home directory, unless C<BASE> is used). An
absolute path, or a path starting with C<~/> (relative to your home
directory), ignores these directories. 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<DIR> I<path>

Sets the directory of the target file, which keeps the name of the fragment
(or the one given by C<FILENAME>, which must then be a relative path). The
path is relative to the base directory (your home directory, unless C<BASE> is
used), unless it is an absolute path or it starts with C<~> (for your home
directory). This directive cannot be used when the target is made of two
commands, nor with C<MIRROR>.

=item C<BASE> I<path>

Sets the base directory of the target, which is your home directory by
default: the C<DIR> and C<FILENAME> paths and the directories given by
C<MIRROR> are relative to it. A relative path is relative to the previous base
directory, which is the one set by a C<BASE> directive in a parent directory
(see L</Directory directives>), if any, or your home directory otherwise. The
path can also be absolute, or start with C<~> for a path relative to your home
directory.

=item C<MIRROR>

Uses the structure of the configuration directory for the target, which is
mostly useful in a F<.update_config> file (see L</Directory directives>): the
directory of the target is the path of the directory of the fragment, starting
with the directory where C<MIRROR> is set (the one containing the
F<.update_config> file, or the fragment itself), relative to the base directory
(see C<BASE>). For example, with C<MIRROR> in F<dot_config/.update_config>, the
fragment F<dot_config/fish/config.fish> targets F<~/.config/fish/config.fish>.
The root of the configuration directory is never part of the mirrored path. As
for the name of the fragment, the suffixes between brackets are removed from
the names of the mirrored directories (a directory whose name is only such a
suffix can't be mirrored) and a C<dot_> prefix is replaced by a dot (e.g.
F<dot_config/app [work]/dot_rc> targets F<.config/app/.rc>). A C<DIR>
directive set deeper than C<MIRROR> replaces the mirrored path (and the
reverse), and C<FILENAME> replaces the name of the fragment.

=item C<MIRROR CONTENTS>

Like C<MIRROR>, but the directory where the directive is set is not part of the
mirrored path, only the directories below it are (e.g. with C<MIRROR CONTENTS>
in F<config/.update_config>, the fragment F<config/fish/config.fish> targets
F<~/fish/config.fish>). The deepest of C<MIRROR> and C<MIRROR CONTENTS> wins.

=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. By default, the suffixes between brackets at the end of the name
of the fragment and of its directories are used, if any (see above). The suffix
is always converted to upper case, whether it comes from this directive or from
the names of the files. With C<MERGE>, there are no guard lines and the suffix
is ignored.

=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. The last applied version of the fragment is saved (see
L</Merged files>) and, if the target was modified since then, it is not
overwritten: the program prints the modifications that would be lost, skips
the fragment and continues with the other ones. The C<--force> option
overwrites the target anyway, and reports it as C<Updated: target (forced)>. A
target that does not exist is always written.

=item C<MAKE EXECUTABLE>

Makes the target file executable.

=item C<MERGE> [I<format>]

Merges the data of the fragment into the target file instead of using guard
lines, see L</Merged files> below. The format is one of C<json>, C<toml>,
C<yaml> or C<ini> (case insensitive). Without a format, it is given by the
extension of the target, which must be the last part of its name, ignoring
the suffix between brackets (e.g. a fragment named F<config.toml [work]> is
merged as C<toml>). The C<yml> extension is recognized too. This directive cannot be used with C<COMMENTS CHAR>,
C<ENTIRE FILE> or C<IS PREFIX>.

=item C<MERGE ARRAYS> I<mode>

With C<MERGE>, sets how the arrays without an explicit mode are merged (see
L</Merged files>): C<union> or C<replace> for all of them, or C<auto> (the
default) to use C<replace> for the arrays that contain only scalars and
C<union> for the others.

=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 Directory directives

A directory of fragments can contain a F<.update_config> file, with directives
(and C<REM> comments) on each line, possibly separated by empty lines, but no
content. These directives apply to all the fragments of the directory,
including those in its sub-directories. If several of these files apply to a
fragment (from its directory and its parent directories), their directives
are combined, starting with the outermost directory and ending with the
directives of the fragment itself:

=over 4

=item *

The C<REQUIRE> directives are all evaluated, the fragment is skipped if any of
them is false.

=item *

For the other directives, the value from the deepest file wins (so the
directives of a fragment override those of its directories). Note that a
directive without a value (e.g. C<ENTIRE FILE>) cannot be disabled once it is
set in a directory.

=item *

A C<GUARD SUFFIX> directive in a F<.update_config> file replaces the suffixes
between brackets of the names of its directory and of the directories above
it, but the suffixes of the directories below it and of the fragment
itself are still added after it (e.g. with a F<.update_config> file containing
C<GUARD SUFFIX work> in F<dir [d]>, the guard suffix of F<dir [d]/sub [s]/file>
is C<WORK-S>). A C<GUARD SUFFIX> directive in a fragment replaces all of these
suffixes.

=item *

A C<COMMENTS CHAR> directive is ignored by the fragments using C<MERGE> when
it is set in a parent directory of the one setting C<MERGE> (otherwise, they
cannot be used together). Similarly, C<MERGE ARRAYS> can be set in a
F<.update_config> file without C<MERGE>, it then only applies to the fragments
that use C<MERGE>.

=item *

The C<BASE> directives are all applied, each relative to the previous one.

=item *

An absolute C<FILENAME> (or a pair of commands, or a path starting with C<~/>)
ignores the C<BASE>, C<DIR>, C<MIRROR> and C<MIRROR CONTENTS> directives set
in a parent directory.

=back

A C<FILENAME> directive in a F<.update_config> file sends all the fragments of
the directory to the same target, which requires them to have different guard
suffixes (e.g. from their names, like F<path [path]> and F<editor [editor]>).

For example, with a F<dot_config/.update_config> file containing:

  MIRROR

the fragment F<dot_config/fish/config.fish> targets
F<~/.config/fish/config.fish>, F<dot_config/git [work]/config> targets
F<~/.config/git/config> (with the C<WORK> guard suffix) and
F<dot_config/app/settings.json> containing C<DIR .config/other> targets
F<~/.config/other/settings.json>. The same targets are obtained with a
F<config/.update_config> file containing:

  BASE .config
  MIRROR CONTENTS

and C<DIR other> in F<config/app/settings.json>.

=head2 Merged files

Some programs rewrite their own configuration file (re-ordering its entries,
removing its comments, etc.), which would break the guard lines. For these
files, the C<MERGE> directive merges the data of the fragment, written in the
same format as the target file, into the existing data of that file:

=over 4

=item *

Maps (TOML tables, JSON objects, YAML mappings or INI sections), starting with
the root of the file, are merged recursively: each key of the fragment is
added to the existing map. For other values, the value from the fragment
replaces the existing one.

=item *

Arrays are merged according to their mode, which is given by an
C<update_config_arrays> map placed next to them in the fragment (that is, in
the map containing the arrays). Each key of that map is the name of an array
and its value is one of:

=over 4

=item C<replace>

The array from the fragment replaces the existing one.

=item C<union>

The elements of the fragment (which can be whole maps, e.g. TOML C<[[array]]>
entries) are appended to the existing array, unless an equal element is
already present.

=item C<key:>I<field>[C<,>I<field>...]

For arrays of maps, the entries of the fragment are matched with the existing
entries having the same value for all the given fields. A matching entry is
merged like any other map (so values added there by the program are kept) and
the entries without a match are appended.

=back

The C<update_config_arrays> maps are not written in the target file. The
arrays not listed in such a map use the mode given by the C<MERGE ARRAYS>
directive (by default, C<replace> for arrays of scalars and C<union> for the
others).

=item *

The target file is entirely rewritten, with sorted keys and without its
comments. But it is not modified at all if it already contains the data of the
fragment, whatever its formatting.

=item *

The last applied version of each fragment (for each target) is saved in
F<$XDG_STATE_HOME/update_config> (F<~/.local/state/update_config> by
default), or in F</var/lib/update_config> for the C<NEED ROOT> fragments
(this can be overridden with the C<UPDATE_CONFIG_ROOT_STATE_DIR> environment
variable). On the next run, the values that were removed from the fragment are
also removed from the target file, unless they were modified there. This also
applies to the elements of arrays merged with C<union>, and to the values of
the entries of arrays merged with a C<key> (such an entry is removed entirely
if only its key fields remain). This is a best effort mechanism that does not
cover the changes made before the state was saved, nor the fragments that were
renamed or moved to another directory since then.

=back

The C<ini> format supports C<key = value> lines, optionally in C<[section]>
blocks, and comment lines starting with C<;> or C<#>. The values are kept as
raw text. The C<json> format accepts trailing commas and C<#> comments but not
C<//> comments.

=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

The following fragments use the C<MERGE> directive, for files that are
rewritten by their program. This one sets a theme and adds a server to a TOML
file, while keeping the other servers configured there (by default, the
C<[[server]]> entries are merged with C<union>):

  FILENAME .config/app/config.toml
  MERGE toml

  [ui]
  theme = "dark"

  [[server]]
  name = "home"
  url = "https://home.example.com"

This one configures some languages in the Helix editor. The entries of the
C<language> array are matched by their C<name>: if a C<rust> entry already
exists, its C<indent> is updated and its other values are kept. The marker for
an array at the root of the file must be placed before any table header:

  FILENAME .config/helix/languages.toml
  MERGE toml

  update_config_arrays = { language = "key:name" }

  [[language]]
  name = "rust"
  indent = { tab-width = 4, unit = "    " }

  [[language]]
  name = "python"
  auto-format = true

This one adds a key binding to Alacritty, where the bindings are identified by
both their C<key> and C<mods> fields. As the C<bindings> array is in the
C<keyboard> table, the marker is placed in that table:

  FILENAME .config/alacritty/alacritty.toml
  MERGE toml

  [keyboard]
  update_config_arrays = { bindings = "key:key,mods" }

  [[keyboard.bindings]]
  key = "N"
  mods = "Control|Shift"
  action = "CreateNewWindow"

And this one adds a list of excluded paths in a JSON file, without removing the
ones that were already present (the array contains only scalars, so it would
be replaced by default):

  FILENAME .config/app/settings.json
  MERGE json

  {
    "update_config_arrays": {"exclude": "union"},
    "exclude": ["node_modules", ".cache"]
  }

=cut

__DATA__
