view release on metacpan or  search on metacpan

script/update_config  view on Meta::CPAN

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) = @_;
  if (exists $conf->{symlink}) {
    write_symlink($out_path, $conf->{symlink});
  } elsif ($conf->{entire_file} or $conf->{merge}) {
    write_content($mode, $out_path, $new_content, $conf);
  } else {
    my $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)};
  return ('', describe_symlink_target($in_path), "-> $conf->{symlink}\n", '')
      if exists $conf->{symlink};
  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;
}