#!/opt/tpkg/bin/perl
##############################################################################
# tpkg package management system
# License: MIT (http://www.opensource.org/licenses/mit-license.php)
##############################################################################

use warnings;
use strict;

use Getopt::Long;
use CPAN;
use Config;
# According to the Changes file for EU::I this is the earliest version
# that supports all of the ExtUtils::Installed->new() parameters we use.
use ExtUtils::Installed 1.41_03;
use File::Temp qw(tempdir);
use File::Find;      # find
use File::Path;      # mkpath
use File::Basename;  # basename, dirname
use File::Copy;      # copy
use File::Spec;      # catdir, catfile, etc.
use Storable qw(dclone);

sub usage
{
	die <<EOF;
Usage: cpan2tpkg [options] module
    [--version version]
       Version of module to install
    [--package-version version]
       Package version to use in tpkg, defaults to 1
    [--extra-deps foo,1.0,1.9999,bar,4.5,4.5,blah,,,]
       Extra dependencies to add to the package
    [--native-deps foo,1.0,1.9999,bar,4.5,4.5,blah,,,]
       Native dependencies to add to the package
    [--force]
       Force the install and packaging even if tests fail
    [--help]
       Show this message

All options can be shortened to anything that's unique.
EOF
}

my $modver;
my $pkgver = 1;
my %extradeps = ();
my $extradepsopts = '';
my %nativedeps = ();
my $nativedepsopts = '';
my $force;
my $help;

my $getopt = GetOptions(
	'version=s' => \$modver,
	'package-version=s' => \$pkgver,
	'extra-deps=s' => \$extradepsopts,
	'native-deps=s' => \$nativedepsopts,
        'force' => \$force,
	'help' => \$help);

my $module = shift @ARGV;

usage() if (!$getopt);
usage() if ($help);
usage() if (!$module);

# FIXME: we're not actually using $modver, we're just letting CPAN install
# the latest available version
if ($modver)
{
	die "--version not implemented\n";
}

my @extradepsopts = split(/,/, $extradepsopts);
while (scalar @extradepsopts)
{
	my $dep = shift @extradepsopts;
	# These are optional, shift will return undef if they aren't present
	# and we'll handle that properly when creating tpkg.yml
	my $depminver = shift @extradepsopts;
	my $depmaxver = shift @extradepsopts;
	$extradeps{$dep} = {};
	$extradeps{$dep}{minimum_version} = $depminver;
	$extradeps{$dep}{maximum_version} = $depmaxver;
}
my @nativedepsopts = split(/,/, $nativedepsopts);
while (scalar @nativedepsopts)
{
	my $dep = shift @nativedepsopts;
	# These are optional, shift will return undef if they aren't present
	# and we'll handle that properly when creating tpkg.yml
	my $depminver = shift @nativedepsopts;
	my $depmaxver = shift @nativedepsopts;
	$nativedeps{$dep} = {};
	$nativedeps{$dep}{minimum_version} = $depminver;
	$nativedeps{$dep}{maximum_version} = $depmaxver;
}

# FIXME, pause for confirmation?
printf "Running under $^X, version %vd\n", $^V;
# Getting the major and minor versions out of $^X looks like it should be
# more straighforward according to the documentation, but the structure of
# $^X is different between Perl 5.8 and 5.10 and despite a few hours of
# trying I'm not smart enough to sort it out.
# Example $] from perl 5.8.8:  5.008008
my ($major, my $minorpatch) = split(/\./, $]);
my ($minor, $patch) = unpack('A3A3', $minorpatch);
# Force conversion to number so that 010 becomes 10, etc.
my $majornum = $major + 0;
my $minornum = $minor + 0;
my $majorminor = "$majornum$minornum";
my $majordotminor = "$majornum.$minornum";

# FIXME: distribute MyConfig.pm?
# MyConfig.pm needs all sorts of OS-specific stuff (paths to make, gzip,
# etc.) so distributing it would be a pain.  For now we don't, and thus
# force the user to do their own CPAN configuration.  In Perl 5.10
# that's fairly painless.

my $modobj = CPAN::Shell->expand('Module', $module);
if (!$modobj)
{
	die "Unable to find $module or something went wrong\n";
}

# Set install location to temp directory
# There are two installers that modules might use to install themselves
# (ExtUtils::MakeMaker or Module::Build), so we have to set two different
# options to cover both possiblities.
my $workdir = tempdir(CLEANUP => 1);
print "Working directory: $workdir\n";
# http://perldoc.perl.org/ExtUtils/MakeMaker.html#DESTDIR
CPAN::Shell->o('conf', 'makepl_arg', "DESTDIR=$workdir");
# http://perldoc.perl.org/Module/Build.html#INSTALL-PATHS
CPAN::Shell->o('conf', 'mbuildpl_arg', "--destdir=$workdir");

# Automatically install dependencies so that we can package them too
CPAN::Shell->o('conf', 'prerequisites_policy', "follow");

# In order for cpan2tpkg to be able to install and package dependencies of the
# user's module we need perl to be able to find modules installed in our
# working directory.
$ENV{PERL5LIB} = File::Spec->catdir($workdir, $Config{sitelib});

# Install the module
if ($force)
{
	CPAN::Shell->force('install', $module);
}
else
{
	CPAN::Shell->install($module);
}

# It is not nearly as straightforward as one might wish to get
# ExtUtils::Installed to inspect only a specified directory structure and not
# include system library directories. EU::I wants to look at a couple of
# system directories from $Config, any directories in the PERL5LIB environment
# variable, and any extra directories you pass it. You can work around the
# system directories from $Config by passing EU::I your own modified $Config
# via the config_override parameter. We override $ENV{PERL5LIB} above.
# And that just leaves it searching the extra directories you pass it via the
# extra_libs parameter. To further complicate matters EU::I searches the
# directories in @INC when asked for the version of an installed module, but
# allows you to customize that via the inc_override parameter.
my @incwork;
foreach my $incdir (@INC)
{
	push(@incwork, File::Spec->catdir($workdir, $incdir));
}
@incwork = sort(@incwork);
# Lie to ExtUtils::Installed about the two directories from %Config it
# cares about so that it only searches our working directory and no
# system directories.
my %myconfig = %{dclone(\%Config)};
$myconfig{archlibexp} = File::Spec->catdir($workdir, $Config{archlibexp});
$myconfig{sitearchexp} = File::Spec->catdir($workdir, $Config{sitearchexp});
my $extinst = ExtUtils::Installed->new(
	config_override=>\%myconfig,
	inc_override=>\@incwork,
	extra_libs=>\@incwork);

print "Installed modules to be packaged (except Perl):\n";
print join(', ', $extinst->modules), "\n";

# Inspect temp directory and package each installed module
MODULE: foreach my $name ($extinst->modules)
{
	next MODULE if ($name eq 'Perl');
	print "Packaging $name\n";
	my %deps = ();
	my $mod = CPAN::Shell->expand('Module', $name);
	# Sometimes calling expand on a result from EU::I->modules doesn't
	# work.  For example, if the user requests Date::Parse that module
	# is part of the TimeDate distribution.  EU::I->modules will return
	# ['Perl', 'TimeDate'], but calling expand on TimeDate fails.
	# FIXME:  We should find an alternative to EU::I->modules,
	# something that returns the distributions installed rather than the
	# modules.
	if (!$mod)
	{
		# If EU::I->modules only returned two results we can safely
		# assume the !Perl one is whatever the user asked to have
		# installed and use its expansion instead.  Continue the example
		# mentioned above, calling expand on TimeDate fails but calling
		# expand on Date::Parse works, for whatever reason.
		if (scalar($extinst->modules) == 2)
		{
			# We've already called expand on the user's request, so we
			# can reuse that result.
			$mod = $modobj;
			warn "Failed to expand $name the usual way, secondary efforts ",
				"successful\n";
		}
		else
		{
			warn "Failed to expand $name, secondary efforts failed, skipping\n";
			next MODULE;
		}
	}
	# Note that this won't work if we ever implement letting the user
	# select a specific version (via the --version CLI option), as
	# expand presumably returns the info for the latest available
	# version of the distribution.  Note that EU::I->version returns the
	# version of the module, not the version of the distribution, and
	# those can differ.  We're packaging the distribution, which may
	# include multiple modules with their own, differing versions.
	my $ver = module_to_dist_ver($mod);
	print "Module version is $ver\n";
	my $pkgname = module_to_pkg_name($mod);
	print "Package name, based on distribution, is $pkgname\n";
	# Looks like newer versions of CPAN.pm have a CPAN::Module::distribution()
	# method.  What I'm using here is a little hacky but works, so I
	# don't think it is worth forcing users to use a newer version.
	my $dist = CPAN::Shell->expand('Distribution', $mod->{RO}{CPAN_FILE});
	# The docs say you have to call make before prereq_pm is available
	$dist->make;
	# If there are any pre-reqs capture those
	if ($dist->prereq_pm)
	{
		# Older versions return a basic {module name => min version} structure
		# Newer versions seperate build-time dependencies (build_requires)
		# from run-time dependencies (requires), each of which has the
		# {name=>minver} format.
		my %prereqs = %{$dist->prereq_pm};
		if (exists $prereqs{requires})
		{
			# If we got back the newer format we want to pull out the run-time
			# requirements. If there are no run-time requirements then
			# $prereqs{requires} will be undef.
			if ($prereqs{requires})
			{
				%prereqs = %{$prereqs{requires}};
			}
			else
			{
				%prereqs = ();
			}
		}
		PREREQ: foreach my $dep (keys %prereqs)
		{
			if ($dep eq 'perl')
			{
				# We always add a dependency on perl anyway, so the
				# module's dependency is only relevant if it specifies a
				# newer version than is running.
				if ($prereqs{$dep} ne '0')
				{
					if ($prereqs{$dep} > $])
					{
						die "Module requires perl >= $prereqs{$dep}, this is $]\n";
					}
				}
			}
			else
			{
				# Skip dependencies on core modules
				my $depmod = CPAN::Shell->expand('Module', $dep);
				# This is a bit of an indirect way to identify core
				# modules but the only way I can figure out.  Core stuff
				# gets installed with perl into /opt/tpkg/perl-version,
				# CPAN modules into /opt/tpkg/lib/perl5/site_perl.
				#
				# What seems like it should be the "right" way is that
				# the "D" (aka "Development Stage") field in
				# dslip_status has "S" (aka "Standard, supplied with
				# Perl 5") as one of its possible values, according to
				# the docs (http://perldoc.perl.org/CPAN.html).
				# However, that doesn't seem to be set reliably.
				if ($depmod->inst_file && $depmod->inst_file =~ /$Config{prefix}/)
				{
					print "Prereq $dep is a core module, skipping\n";
					next PREREQ;
				}
				
				my $deppkgname = module_to_pkg_name($depmod);
				$deps{$deppkgname} = {};
				if ($prereqs{$dep} ne '0')
				{
					$deps{$deppkgname}{minimum_version} = $prereqs{$dep};
				}
			}
		}
	}
	my $tpkgdir = tempdir(CLEANUP =>1);
	print "Packaging into $tpkgdir\n";
	mkdir("$tpkgdir/root");
	my $nativefile;
	foreach my $packlistfile ($extinst->files($name))
	{
		chomp($packlistfile);
		# Chop off $workdir
		$packlistfile =~ s/^$workdir//;
		# Make directory tree in $tpkgdir
		mkpath("$tpkgdir/root/" . dirname($packlistfile));

		# Copy file
		my $src = "$workdir/$packlistfile";
		my $dst = "$tpkgdir/root/$packlistfile";
		copy($src, $dst);

		# preserve permissions
		# (avoiding dependency on File::Copy::Recursive::fcopy)
		my $mode = (stat($src))[2];
		chmod($mode & 07777, $dst);

		if ($packlistfile =~ quotemeta($Config{archname}))
		{
			$nativefile = 1;
		}
	}
	# Create tpkg.yml
	open(my $ymlfh, '>', "$tpkgdir/tpkg.yml") or die;
	print $ymlfh "name: cpan-perl$majorminor-$pkgname", "\n";
	print $ymlfh "version: $ver", "\n";
	print $ymlfh "package_version: $pkgver", "\n";
	print $ymlfh "description: cpan package for $pkgname", "\n";
	print $ymlfh 'maintainer: cpan2tpkg', "\n";
	# If the package has native code then it needs to be flagged as
	# specific to the OS and architecture
	if ($nativefile)
	{
		my $os;
		my $arch;
		open(my $tpkgqefh, '-|', 'tpkg --qe') or die;
		while(my $tpkgqeline = <$tpkgqefh>)
		{
			chomp($tpkgqeline);
			if ($tpkgqeline =~ /^Operating System: (.*)/)
			{
				$os = $1;
			}
			elsif ($tpkgqeline =~ /^Architecture: (.*)/)
			{
				$arch = $1;
			}
		}
		close($tpkgqefh);
		if (!$os || !$arch)
		{
			die "Unable to read OS and architecture from tpkg --qe";
		}
		# Packages built on Red Hat should work on CentOS and
		# vice-versa
		if ($os =~ /RedHat-(.*)/)
		{
			$os = $os . ", CentOS-$1";
		}
		elsif ($os =~ /CentOS-(.*)/)
		{
			$os = $os . ", RedHat-$1";
		}
		print $ymlfh "operatingsystem: [$os]", "\n";
		print $ymlfh "architecture: [$arch]", "\n";
	}
	# Insert appropriate dependencies into the package
	print $ymlfh 'dependencies:', "\n";
	foreach my $dep (keys %deps)
	{
		print $ymlfh "  - name: cpan-perl$majorminor-$dep", "\n";
		if ($deps{$dep}{minimum_version})
		{
			print $ymlfh "    minimum_version: $deps{$dep}{minimum_version}", "\n";
		}
		if ($deps{$dep}{maximum_version})
		{
			print $ymlfh "    maximum_version: $deps{$dep}{maximum_version}", "\n";
		}
	}
	foreach my $extradep (keys %extradeps)
	{
		print $ymlfh "  - name: $extradep", "\n";
		if ($extradeps{$extradep}{minimum_version})
		{
			print $ymlfh "    minimum_version: $extradeps{$extradep}{minimum_version}", "\n";
		}
		if ($extradeps{$extradep}{maximum_version})
		{
  		print $ymlfh "    maximum_version: $extradeps{$extradep}{maximum_version}", "\n";
		}
	}
	foreach my $nativedep (keys %nativedeps)
	{
		print $ymlfh "  - name: $nativedep", "\n";
		if ($nativedeps{$nativedep}{minimum_version})
		{
			print $ymlfh "    minimum_version: $nativedeps{$nativedep}{minimum_version}", "\n";
		}
		if ($nativedeps{$nativedep}{maximum_version})
		{
			print $ymlfh "    maximum_version: $nativedeps{$nativedep}{maximum_version}", "\n";
		}
		print $ymlfh '    native: true', "\n";
	}
	# Insert an appropriate dependency on Perl itself
	print $ymlfh '  - name: perl', "\n";
	print $ymlfh '    minimum_version: ', sprintf("%vd", $^V), "\n";
	print $ymlfh "    maximum_version: $majordotminor.9999", "\n";
	# Build package
	system("tpkg --make $tpkgdir");
}

# Pass in an expanded module (CPAN::Shell->expand), get back a name
# suitable for use in packaging.
# The package name is based on the distribution that contains the
# module, as sometimes multiple modules are packaged into a single
# distribution file.
sub module_to_pkg_name
{
	my $mod = shift;
	my $distfilename = basename($mod->{RO}{CPAN_FILE});
	my $pkgname = $distfilename;
	# Cut off the version and suffix
	# I.e. TimeDate-1.20.tar.gz -> TimeDate
	$pkgname =~ s/-\d.*//;
	return $pkgname;
}
# Pass in an expanded module (CPAN::Shell->expand), get back the version
# of the associated distribution.
sub module_to_dist_ver
{
	my $mod = shift;
	my $distfilename = basename($mod->{RO}{CPAN_FILE});
	# Cut off the distribution name and suffix
	# I.e. TimeDate-1.20.tar.gz -> 1.20
	$distfilename =~ /-(\d.*?)\.\D/;
	my $distver = $1;
	return $distver;
}