#!/usr/bin/perl

=head1 NAME

dh_installalternatives - install declarative alternative rules

=cut

use strict;
use warnings;
use constant LINE_PREFIX => ' ' . q{\\} . "\n            ";
use Debian::Debhelper::Dh_Lib;

our $VERSION = DH_BUILTIN_VERSION;

=head1 SYNOPSIS

B<dh_installalternatives> [S<I<debhelper options>>]

=head1 DESCRIPTION

B<dh_installalternatives> is a debhelper program that is responsible for
parsing the declarative alternatives format and insert the relevant
maintscripts snippets to interface with L<update-alternatives(1)>

=head1 FILES

=over 4

=item debian/I<package>.alternatives

An example of the format:

    Name: editor
    Link: /usr/bin/editor
    Alternative: /usr/bin/vim.basic
    Dependents:
      /usr/share/man/man1/editor.1.gz editor.1.gz /usr/share/man/man1/vim.1.gz
      /usr/share/man/fr/man1/editor.1.gz editor.fr.1.gz /usr/share/man/fr/man1/vim.1.gz
      /usr/share/man/it/man1/editor.1.gz editor.it.1.gz /usr/share/man/it/man1/vim.1.gz
      /usr/share/man/pl/man1/editor.1.gz editor.pl.1.gz /usr/share/man/pl/man1/vim.1.gz
      /usr/share/man/ru/man1/editor.1.gz editor.ru.1.gz /usr/share/man/ru/man1/vim.1.gz
    Priority: 50

The fields B<Link>, B<Name>, B<Alternative>, and B<Priority> are mandatory and correspond
to the L<update-alternatives(1)> B<--install> parameters B<link>, B<name>, B<path>, and
B<priority> respectively.

The B<Dependents> field is optional and consists of one or more lines. Each non-empty
line must contain exactly 3 space separated values that match (in order) the values passed
to the B<--slave> parameter for L<update-alternatives(1)>.

=back

=head1 OPTIONS

=over 4

=item B<-n>, B<--no-scripts>

Do not modify F<postinst>/F<postrm>/F<prerm> scripts.

=back

=cut

init();

# Explicitly discard attempts to use --name; it does not make sense for
# this helper.
if ($dh{NAME}) {
	warning('Ignoring unsupported --name option');
}
$dh{NAME} = undef;

# PROMISE: DH NOOP WITHOUT alternatives cli-options()

foreach my $package (@{$dh{DOPACKAGES}}) {
	my $tmp = tmpdir($package);
	my $alternatives = pkgfile($package, 'alternatives');

	if (-f $alternatives) {
		_parse_alternatives_file_and_generate_maintscripts($package, $tmp, $alternatives);
	}
}

sub _parse_alternative_and_generate_maintscript {
	my ($package, $tmpdir, $alternatives_file, $ctrl) = @_;

	my $link_name = $ctrl->{'Name'} // error("Missing mandatory \"Name\" field in ${alternatives_file}");
	my $link_path = $ctrl->{'Link'}
		// error("Missing mandatory \"Link\" field for \"${link_name}\" in ${alternatives_file}");
	my $impl_path = $ctrl->{'Alternative'}
		// error("Missing mandatory \"Alternative\" field for \"${link_name}\" in ${alternatives_file}");
	my $priority = $ctrl->{'Priority'}
		// error("Missing mandatory \"Priority\" field for \"${link_name}\" in ${alternatives_file}");
	my %maintscript_options;

	if (index($link_name, '/') > -1) {
		error(qq{Invalid link name "${link_name}" in "${alternatives_file}": Must not contain slash});
	}
	my $actual_impl_path = "${tmpdir}/${impl_path}";
	if ( ! -l $actual_impl_path && ! -e _) {
		error(qq{Alternative "${impl_path}" for "${link_name}" in ${alternatives_file} does not exist in ${tmpdir}});
	}
	if ( -d $actual_impl_path) {
		error(qq{Alternative "${impl_path}" for "${link_name}" in ${alternatives_file} is a directory});
	}
	if ($link_name eq $impl_path) {
		error(qq{The link name cannot be the same as the implementation path "${link_name}" (in "${alternatives_file}")});
	}

	$maintscript_options{'RM_OPTIONS'} = "--remove ${link_name} ${impl_path}";
	$maintscript_options{'INSTALL_OPTIONS'} = "--install ${link_path} ${link_name} ${impl_path} ${priority}";

	if (defined(my $slave_link_text = $ctrl->{'Dependents'})) {
		my (%dlink_dup, @dependent_links);
		for my $line (split(/\n/, $slave_link_text)) {
			my ($dlink_name, $dlink_path, $dimpl_path, $trailing);
			my $error_with_def = 0;
			$line =~ s/^\s++//;
			$line =~ s/\s++$//;
			next if $line eq '';  # Ignore empty lines
			($dlink_path, $dlink_name, $dimpl_path, $trailing) = split(' ', $line, 4);
			if (not $dlink_name) {
				warning(qq{Missing link name value (2nd item) for dependent link "${dlink_name}" for "${link_name}"}
					. qq{ in "${alternatives_file}"});
				$error_with_def = 1;
			} elsif (index($dlink_name, '/') > -1) {
				warning(qq{Invalid dependent link name "${dlink_name}" for "${link_name}"}
					. qq{ in "${alternatives_file}": Must not contain slash});
				$error_with_def = 1;
			} elsif ($dlink_dup{$dlink_name}) {
				warning(qq{Dependent link "${dlink_name}" is seen more than once for "${link_name}"}
					. qq{ in ${alternatives_file}});
				$error_with_def = 1;
			}
			if (not $dimpl_path) {
				warning(qq{Missing path (alternative) value (3rd item) for dependent link "${dlink_name}"}
					. qq{ for "${link_name}" in "${alternatives_file}"});
				$error_with_def = 1;
			}
			if ($dlink_name eq $dimpl_path) {
				warning(qq{The link name cannot be the same as the implementation path for "${dlink_name}"}
						. qq{ in "${alternatives_file}"});
				$error_with_def = 1;
			}
			if ($trailing) {
				warning(qq{Trailing information for dependent link "${dlink_name}" for "${link_name}"}
					. qq{ in "${alternatives_file}"});
				warning("Dependent links must consist of exactly 3 space-separated values");
				$error_with_def = 1;
			}
			if ($error_with_def) {
				my $link_id = $dlink_name // ('no ' . (scalar(@dependent_links) + 1));
				error("Error parsing dependent link ${link_id} for \"${link_name}\" in ${alternatives_file}.");
			}
			push(@dependent_links, "--slave $dlink_path $dlink_name $dimpl_path");
		}
		error("Empty \"Dependents\" field for \"${link_name}\" in ${alternatives_file} (please remove it or add an entry)")
			if not @dependent_links;
		$maintscript_options{'INSTALL_OPTIONS'} .=  LINE_PREFIX . join(LINE_PREFIX, @dependent_links);
	}
	for my $wrong_name (qw(Slave Slaves Slave-Links)) {
		if ($ctrl->{$wrong_name}) {
			error("Please use Dependents instead of ${wrong_name}");
		}
	}

	autoscript($package, 'postinst', 'postinst-alternatives', \%maintscript_options);
	autoscript($package, 'prerm', 'prerm-alternatives', \%maintscript_options);
	return;
}

sub _parse_alternatives_file_and_generate_maintscripts {
	my ($package, $tmpdir, $alternatives_file) = @_;
	my ($ctrl, $fd);
	require Dpkg::Control::HashCore;
	open($fd, '<', $alternatives_file) or error("open $alternatives_file failed: $!");
	while (defined($ctrl = Dpkg::Control::HashCore->new) and ($ctrl->parse($fd, $alternatives_file))) {
		_parse_alternative_and_generate_maintscript($package, $tmpdir, $alternatives_file, $ctrl);
	}
	close($fd);
	return;
}

=head1 SEE ALSO

L<debhelper(7)>

This program is a part of debhelper.

=cut