#!/usr/bin/perl -w

use strict;
use warnings FATAL => 'all';
use Test::More tests => 125;

use Config;
use File::Temp ();

use File::Spec::Functions qw/catdir splitdir splitpath tmpdir/;
my $tmp = File::Temp::tempdir('EIP-XXXXXXXX', CLEANUP => 1, DIR => File::Spec->tmpdir);

use ExtUtils::Config;
use ExtUtils::InstallPaths;

#########################

# We need to create a well defined environment to test install paths.
# We do this by setting up appropriate Config entries.

my @installstyle = qw(lib perl5);
my $config = ExtUtils::Config->new({
	installstyle	=> catdir(@installstyle),

	installprivlib  => catdir($tmp, @installstyle),
	installarchlib  => catdir($tmp, @installstyle, @Config{qw(version archname)}),
	installbin      => catdir($tmp, 'bin'),
	installscript   => catdir($tmp, 'bin'),
	installman1dir  => catdir($tmp, 'man', 'man1'),
	installman3dir  => catdir($tmp, 'man', 'man3'),
	installhtml1dir => catdir($tmp, 'html'),
	installhtml3dir => catdir($tmp, 'html'),

	installsitelib      => catdir($tmp, 'site', @installstyle, 'site_perl'),
	installsitearch     => catdir($tmp, 'site', @installstyle, 'site_perl', @Config{qw(version archname)}),
	installsitebin      => catdir($tmp, 'site', 'bin'),
	installsitescript   => catdir($tmp, 'site', 'bin'),
	installsiteman1dir  => catdir($tmp, 'site', 'man', 'man1'),
	installsiteman3dir  => catdir($tmp, 'site', 'man', 'man3'),
	installsitehtml1dir => catdir($tmp, 'site', 'html'),
	installsitehtml3dir => catdir($tmp, 'site', 'html'),
});

my $mb = ExtUtils::InstallPaths->new(installdirs => 'site', config => $config, dist_name => 'ExtUtils-InstallPaths');
isa_ok($mb, 'ExtUtils::InstallPaths');

# Get us into a known state.
$mb->install_base(undef);
$mb->prefix(undef);

{
	# Check install_path() accessor
	my ($map, $path);

	$map = $mb->install_path();
	is_deeply($map, {}, 'install_path() accessor');

	$path = $mb->install_path('elem' => '/foo/bar');
	is($path, '/foo/bar', '  returns assigned path');

	$path = $mb->install_path('elem');
	is($path, '/foo/bar', '  can read stored path');

	$map = $mb->install_path();
	is_deeply($map, { 'elem' => '/foo/bar' }, '  can access map');

	$path = $mb->install_path('elem' => undef);
	is($path, undef, '  can delete a path element');

	$map = $mb->install_path();
	is_deeply($map, {}, '  deletes path from map');
}

# Check install_base_relpaths() accessor
{
	my ($map, $path);

	$map = $mb->install_base_relpaths();
	is(ref($map), 'HASH', 'install_base_relpaths() accessor');

	eval{ $path = $mb->install_base_relpaths('elem' => '/foo/bar') };
	like($@, qr/Value must be a relative path/, '  emits error if path not relative');

	$path = $mb->install_base_relpaths('elem' => 'foo/bar');
	is($path, catdir(qw(foo bar)), '  returns assigned path');

	$path = $mb->install_base_relpaths('elem');
	is($path, catdir(qw(foo/bar)), '  can read stored path');

	$map = $mb->install_base_relpaths();
	is_deeply($map->{elem}, [qw(foo bar)], '  can access map');

	$path = $mb->install_base_relpaths('elem' => undef);
	is($path, undef, '  can delete a path element');

	$map = $mb->install_base_relpaths();
	is($map->{elem}, undef, '  deletes path from map');
}


# Check prefix_relpaths() accessor
{
	my ($map, $path);

	$map = $mb->prefix_relpaths();
	is(ref($map), 'HASH', 'prefix_relpaths() accessor');

	is_deeply($mb->prefix_relpaths(), $mb->prefix_relpaths('site'), '  defaults to \'site\'');

	eval{ $path = $mb->prefix_relpaths('site', 'elem' => '/foo/bar') };
	like($@, qr/Value must be a relative path/, '  emits error if path not relative');

	$path = $mb->prefix_relpaths('site', 'elem' => 'foo/bar');
	is($path, catdir(qw(foo bar)), '  returns assigned path');

	$path = $mb->prefix_relpaths('site', 'elem');
	is($path, catdir(qw(foo bar)), '  can read stored path');

	$map = $mb->prefix_relpaths();
	is_deeply($map->{elem}, [qw(foo bar)], '  can access map');

	$path = $mb->prefix_relpaths('site', 'elem' => undef);
	is($path, undef, '  can delete a path element');

	$map = $mb->prefix_relpaths();
	is($map->{elem}, undef, '  deletes path from map');
}


# Check that we install into the proper default locations.
{
	is($mb->installdirs, 'site');
	is($mb->install_base, undef);
	is($mb->prefix,       undef);

	test_install_destinations($mb, {
		lib     => catdir($tmp, 'site', @installstyle, 'site_perl'),
		arch	=> catdir($tmp, 'site', @installstyle, 'site_perl', @Config{qw(version archname)}),
		bin     => catdir($tmp, 'site', 'bin'),
		script  => catdir($tmp, 'site', 'bin'),
		bindoc  => catdir($tmp, 'site', 'man', 'man1'),
		libdoc  => catdir($tmp, 'site', 'man', 'man3'),
		binhtml => catdir($tmp, 'site', 'html'),
		libhtml => catdir($tmp, 'site', 'html'),
	});
	test_install_map($mb, {
		read                      => '',
		write                     => File::Spec->catfile($mb->install_destination('arch'), qw/auto ExtUtils InstallPaths .packlist/),
		catdir('blib', 'lib')     => catdir($tmp, 'site', @installstyle, 'site_perl'),
		catdir('blib', 'arch')    => catdir($tmp, 'site', @installstyle, 'site_perl', @Config{qw(version archname)}),
		catdir('blib', 'bin')     => catdir($tmp, 'site', 'bin'),
		catdir('blib', 'script')  => catdir($tmp, 'site', 'bin'),
	}, 'installdirs=site');
}

# Is installdirs honored?
{
	$mb->installdirs('core');
	is($mb->installdirs, 'core');

	test_install_destinations($mb, {
		lib     => catdir($tmp, @installstyle),
		arch	=> catdir($tmp, @installstyle, @Config{qw(version archname)}),
		bin     => catdir($tmp, 'bin'),
		script  => catdir($tmp, 'bin'),
		bindoc  => catdir($tmp, 'man', 'man1'),
		libdoc  => catdir($tmp, 'man', 'man3'),
		binhtml => catdir($tmp, 'html'),
		libhtml => catdir($tmp, 'html'),
	});

	$mb->installdirs('site');
	is($mb->installdirs, 'site');
}


# Check install_base()
{
	my $install_base = catdir('foo', 'bar');
	$mb->install_base($install_base);

	is($mb->prefix, undef);
	is($mb->install_base, $install_base);


	test_install_destinations($mb, {
		lib     => catdir($install_base, 'lib', 'perl5'),
		arch	=> catdir($install_base, 'lib', 'perl5', $Config{archname}),
		bin     => catdir($install_base, 'bin'),
		script  => catdir($install_base, 'bin'),
		bindoc  => catdir($install_base, 'man', 'man1'),
		libdoc  => catdir($install_base, 'man', 'man3'),
		binhtml => catdir($install_base, 'html'),
		libhtml => catdir($install_base, 'html'),
	});

	test_install_map($mb, {
		read                      => '',
		write                     => File::Spec->catfile($mb->install_destination('arch'), qw/auto ExtUtils InstallPaths .packlist/),
		catdir('blib', 'lib')     => catdir($install_base, 'lib', 'perl5'),
		catdir('blib', 'arch')    => catdir($install_base, 'lib', 'perl5', $Config{archname}),
		catdir('blib', 'bin')     => catdir($install_base, 'bin'),
		catdir('blib', 'script')  => catdir($install_base, 'bin'),
	}, 'install_base');
}


# Basic prefix test.  Ensure everything is under the prefix.
{
	$mb->install_base(undef);
	ok(!defined $mb->install_base);

	my $prefix = catdir(qw/some prefix/);
	$mb->prefix($prefix);
	is($mb->{prefix}, $prefix);

	test_prefix($prefix, $mb->install_sets('site'));
}

# And now that prefix honors installdirs.
{
	$mb->installdirs('core');
	is($mb->installdirs, 'core');

	my $prefix = catdir(qw/some prefix/);
	test_prefix($prefix);

	$mb->installdirs('site');
	is($mb->installdirs, 'site');
}

# Try a config setting which would result in installation locations outside
# the prefix.  Ensure it doesn't.
{
	# Get the prefix defaults
	my $defaults = $mb->prefix_relpaths('site');

	# Create a configuration involving weird paths that are outside of
	# the configured prefix.
	my @prefixes = ([qw(foo bar)], [qw(biz)], []);

	my %test_config;
	foreach my $type (keys %$defaults) {
		my $prefix = shift @prefixes || [qw(foo bar)];
		$test_config{$type} = catdir(File::Spec->rootdir, @$prefix, @{$defaults->{$type}});
	}

	# Poke at the innards of E::IP to change the default install locations.
	my $old =  $mb->install_sets->{site};
	$mb->install_sets->{site} = \%test_config;
	$mb->config->set(siteprefixexp => catdir(File::Spec->rootdir, 'wierd', 'prefix'));

	my $prefix = catdir('another', 'prefix');
	$mb->prefix($prefix);
	test_prefix($prefix, \%test_config);
	$mb->install_sets->{site} = $old;
}


# Check that we can use install_base after setting prefix.
{
	my $install_base = catdir('foo', 'bar');
	$mb->install_base($install_base);

	test_install_destinations($mb, {
		lib     => catdir($install_base, 'lib', 'perl5'),
		arch	=> catdir($install_base, 'lib', 'perl5', $Config{archname}),
		bin     => catdir($install_base, 'bin'),
		script  => catdir($install_base, 'bin'),
		bindoc  => catdir($install_base, 'man', 'man1'),
		libdoc  => catdir($install_base, 'man', 'man3'),
		binhtml => catdir($install_base, 'html'),
		libhtml => catdir($install_base, 'html'),
	});
}

sub dir_contains {
	my ($first, $second) = @_;
	# File::Spec doesn't have an easy way to check whether one directory
	# is inside another, unfortunately.

	($first, $second) = map { File::Spec->canonpath($_) } ($first, $second);
	my @first_dirs = File::Spec->splitdir($first);
	my @second_dirs = File::Spec->splitdir($second);

	return 0 if @second_dirs < @first_dirs;

	my $is_same = ( File::Spec->case_tolerant ? sub { lc(shift()) eq lc(shift()) } : sub { shift() eq shift() });

	while (@first_dirs) {
		return 0 unless $is_same->(shift @first_dirs, shift @second_dirs);
	}

	return 1;
}


sub test_prefix {
	my ($prefix, $test_config) = @_;

	local $Test::Builder::Level = $Test::Builder::Level + 1;

	foreach my $type (qw/lib arch bin script bindoc libdoc binhtml libhtml/) {
		my $dest = $mb->install_destination($type);
		ok dir_contains($prefix, $dest), "$type prefixed";

		SKIP: {
			skip("'$type' not configured", 1) unless $test_config && $test_config->{$type};

			have_same_ending($dest, $test_config->{$type}, "  suffix correctish ($test_config->{$type} + $prefix = $dest)");
		}
	}
}

sub have_same_ending {
	my ($dir1, $dir2, $message) = @_;

	$dir1 =~ s{/$}{} if $^O eq 'cygwin'; # remove any trailing slash
	my (undef, $dirs1, undef) = splitpath $dir1;
	my @dir1 = splitdir $dirs1;

	$dir2 =~ s{/$}{} if $^O eq 'cygwin'; # remove any trailing slash
	my (undef, $dirs2, undef) = splitpath $dir2;
	my @dir2 = splitdir $dirs2;

	is $dir1[-1], $dir2[-1], $message;
}

sub test_install_destinations {
	my ($build, $expect) = @_;

	local $Test::Builder::Level = $Test::Builder::Level + 1;

	while(my ($type, $expect) = each %$expect) {
		is($build->install_destination($type), $expect, "$type destination");
	}
}

sub test_install_map {
	my ($paths, $expect, $case) = @_;

	local $Test::Builder::Level = $Test::Builder::Level + 1;

	my $map = $paths->install_map;
	while(my ($type, $expect) = each %$expect) {
		is($map->{$type}, $expect, "$type destination for $case");
	}
}