#!/usr/bin/perl

=head1 NAME

splitout_tdeb - splits out a Debian TDeb from a .deb on-the-fly

=cut

=head1 Description

Splits a Debian package into a Debian TDeb and a smaller Debian
package by unpacking, moving relevant files and repacking with
a note in the description and the +t1 version suffix.

When creating a repository containing TDebs, it is strongly
recommended to specify .changes files so that the repository
can include the original sources, for legal reasons.

If a file exists with the same name in the output directory, it
will be overwritten.

=cut

=head1 Copyright and Licence

 Copyright (C) 1997-2000  Roman Hodek <roman@hodek.net>
 Copyright (C) 2000-2002  Colin Watson <cjwatson@debian.org>
 Copyright (C) 2002-2004  David Schleef <ds@schleef.org>
 Copyright (C) 2004  Nikita Youshchenko <yoush@cs.msu.su>
 Copyright (C) 2004  Raphael Bossek <bossekr@debian.org>
 Copyright (C) 2007-2008  Neil Williams <codehelp@debian.org>

 This package is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
 the Free Software Foundation; either version 3 of the License, or
 (at your option) any later version.

 This program is distributed in the hope that it will be useful,
 but WITHOUT ANY WARRANTY; without even the implied warranty of
 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 GNU General Public License for more details.

 You should have received a copy of the GNU General Public License
 along with this program.  If not, see <http://www.gnu.org/licenses/>.

=cut

use Carp;
use Cwd;
use POSIX;
use POSIX qw(:errno_h :signal_h);
use IO::Handle;
use Debian::Debhelper::Dh_Lib;
use File::Basename;
use File::Temp qw/tempfile tempdir/;
use Dpkg::Deps;
use strict;
use warnings;
use vars qw/ $progname $verbose $our_version $tmpdir $package
$nofailmsg $debname $mode %builds $deb $retval $outdir
%options $essential $docs $splittdeb %files $help @filelist
@src @debs @gripped $changes $arch @files_content $src $dst /;

$progname = basename ($0);
$verbose = 1;
$our_version = '0.0.3'; # not from Emdebian::Tools
@src=();

=head1 Converting to TDebs

The idea here is based on dpkg-cross:

 1. receive .deb or .changes as a command-line option
 2. unpack the .deb as dpkg-cross does
 3. create control data for the new TDeb
 4. relocate files into the TDeb
 5. repack the .deb with a TDeb version suffix.
 6. rebuild the original .deb and revise .changes so that the
     original source can be retained.

As few dependencies as possible - this script should
be transformed into more usable TDeb support.

Future versions will also have to understand Dpkg Classes
but until those are implemented, this uses brute force.

=cut

=head1 Automation

Relatively simple, but a few checks are needed in case your list of
possible packages includes packages already processed by dpkg-cross.

 #!/bin/sh
 set -e

 DIR=/tmp/myrepo/
 for deb in `ls /var/cache/apt/archives/*.deb`; do
    cross=`echo $deb | grep "\-.*-cross" || true`
    if [ ! -z "$cross" ]; then
        echo "skipping dpkg-cross package: $deb"
        continue
    fi
    /usr/share/emdebian-tools/splitout_tdeb -o $DIR $deb
 done

A similar script should be able to cope with obtaining .changes files
to retain the source packages.

Despite using dcut internally, splitout_tdeb isn't set up to obtain the
.changes files directly from http://incoming.debian.org, a wrapper
script would be needed.

An additional wrapper is likely to be needed to allow a TDeb
repository to "catch-up" with the existing Debian mirrors, e.g. if the
first upload to the TDeb repository is a binary-only upload without a
referenced .orig.tar.gz. See emdebian-grip for how this could work.

splitout_tdeb does ensure that the .tar.gz is copied into the output
directory and reprepro can locate the relevant files if the
--ignore=missingfile option is passed. Sadly, this functionality is not
preserved in the reprepro processincoming mode.

=cut

=head1 Problems

Many. :-)

Needs more work, probably to allow (or make default) the option *not* to
rebuild the binary package but that depends on the binary already
supporting a TDeb. Right now, this is a quick hack to get some TDebs
easily. splitout_tdeb probably does not deserve to go into a stable
release, the support should be implemented directly within the Debian
builds.

The TDeb generated uses the B<source package name> which will complicate
things if you try to generate TDebs from binaries belonging to the same
source package - use dpkg-gentdeb or dh_gentdeb from within the (native)
package build instead.

Also, strict dependencies are not altered by splitout_tdeb - if another
package (typically from the same source package) has a strict dependency
on a package rebuilt by splitout_tdeb, that package is likely to become
uninstallable. i.e. if foo depends on bar (= 1.2.3-4) and bar is rebuilt
by splitout_deb, bar will become 1.2.3-4+t1 and foo will be 
uninstallable. As above, the solution is to prepare the TDeb from within
the normal package build. emdebian-grip has also solved this problem but
splitout_tdeb is only a convenience script and does not (yet) use this
support.

Use the --verbose option to see the generated control file content of
the TDeb and the modified binary package.

splitout_tdeb also does not (yet) support +t2 or other revisions of the
TDeb - this needs support in dpkg for .diff1.gz so that the +t2 can be
uploaded without affecting the binary package(s). The entire mechanism
for how translators will update TDebs is yet to be implemented.

=cut

while( @ARGV ) {
	$_= shift( @ARGV );
	last if m/^--$/;
	if (!/^-/) {
		unshift(@ARGV,$_);
		last;
	} elsif (/^(-\?|-h|--help|--version)$/) {
		&usageversion();
		exit (0);
	} elsif (/^(-v|--verbose)$/) {
		$verbose++;
	} elsif (/^(-q|--quiet)$/) {
		$verbose--;
	} elsif (/^(-o|--outdir)$/) {
		$outdir = shift;
		die "'$outdir' is not a directory.\n"
			if (not -d $outdir);
		$outdir =~ s:/$::;
	} else {
		die "$progname: Unknown option $_.\n";
	}
}

die "$progname: Please specify some packages to convert into TDebs.\n"
	if (not defined @ARGV);
$retval = 0;
$outdir = ($ENV{'TMPDIR'} and -d $ENV{'TMPDIR'}) ? 
	$ENV{'TMPDIR'} : '/tmp' if (not defined $outdir);

opendir (OUT, $outdir) or die ("Cannot open $outdir: $!\n");
my @list=grep(!/^\.\.?$/, readdir(OUT));
closedir (OUT);
foreach my $f (@list) {
	$files{$f}++;
}

# ensure unique package names.
foreach $package ( @ARGV ) {
	if (not -f $package) {
		warn ("Cannot find $package: $!\n");
		next;
	}
	if ($package =~ /\.changes$/) {
		$changes = $outdir . "/" . basename ($package);
		# convert a .changes file to an array of .deb
		@debs = `dcmd ls $package  2>/dev/null | grep -E '\.[t|u]?deb\$'`;
		@src = `dcmd ls $package  2>/dev/null | grep -vE '\.[t|u]?deb\$'`;
		chomp (@debs);
		chomp (@src);
		foreach my $d (@debs) {
			if (-f "$d") {
				print "Adding $d from $package.\n" if ($verbose >= 2);
				push @filelist, $d;
			}
		}
	} else {
		print "Adding $package from $package.\n" if ($verbose >= 2);
		push @filelist, $package;
	}
}

foreach $package ( @filelist ) {
	next if (not -f $package);
	my $t = basename ($package);
	warn ("Warning: $package already exists. Overwriting.\n")
		if (defined $files{$t});
	$builds{"$package"}++;
}

die ("$progname: Unable to locate any files to process.\n")
	if (scalar @filelist == 0);

# identify details for TDeb
my $source = `dpkg-deb -f $filelist[0] Source`;
chomp ($source);
my $tpackage = `dpkg-deb -f $filelist[0] Package`;
chomp ($tpackage);
$source = $tpackage if ($source eq "");
chomp ($source);
my $tdebdir = dirname $filelist[0];
my $version = `dpkg-deb -f $filelist[0] Version`;
chomp($version);
my $tversion = ($version =~ /\Q+t1\E$/) ? $version : $version.'+t1';
my $tmaint = `dpkg-deb -f $filelist[0] Maintainer`;
chomp($tmaint);
push @files_content, "${source}-locale misc extra\n";
my $newdeb = "Package: ${source}-locale\n";
$newdeb .= "Source: $source\n";
$newdeb .= "Architecture: all\n";
$newdeb .= "Maintainer: $tmaint\n";
$newdeb .= "Priority: extra\n";
$newdeb .= "Version: $tversion\n";
$newdeb .= "Section: misc\n";
# error in the control file handling - this fails.
$newdeb .= "Depends: $tpackage (>= $version)\n";
$newdeb .= "Replaces: $tpackage (<= $tversion)\n";
$newdeb .= "Description: Translations for $source (tdeb)\n";
$newdeb .= "Package-Type: tdeb\n";
$newdeb .= "\n";

# copy sources over to $outdir
foreach my $s (@src) {
	my $sfile = basename ($s);
	open (SRC, "$s") or die ("Cannot open $s: $!\n");
	my @cont=<SRC>;
	close (SRC);
	open (DEST, ">$outdir/$sfile") or die ("Cannot open $outdir/$sfile: $!\n");
	print DEST @cont;
	close (DEST);
}

foreach $package ( keys %builds) {
	$deb = &build( $package, "$outdir" );
	if (not defined $deb) {
		$retval = 1;
	} else {
		push @gripped, $deb;
	}
}

exit ($retval) if ($retval > 0);

# prepare debian/files content
foreach my $d (@gripped) {
	my $files_priority = `dpkg-deb -f $outdir/$d Priority`;
	my $files_section = `dpkg-deb -f $outdir/$d Section`;
	$arch = `dpkg-deb -f $outdir/$d Architecture`;
	chomp ($files_section);
	chomp ($files_priority);
	chomp ($arch);
	my $name = basename ($d);
	push @files_content, "$name $files_section $files_priority\n";
}

# unpack the sources and re-generate the .changes file without changing
# the source package.
# use dget to ensure .orig.tar.gz exists, even for binary-only uploads,
# but that means depending on devscripts.
foreach my $s (@src) {
	next if ($s !~ /\.dsc$/);
	my $dir = dirname ($s);
	my $olddir = cwd;
	my $dsc = basename ($s);
	my $dscdir;
	chdir ($outdir);
	open (DSC, "$s") or die ("Cannot read $s: $!\n");
	my @dsclines=<DSC>;
	close (DSC);
	foreach my $l (@dsclines) {
		$l =~ /.* (.*)[\.orig]?\.tar\.gz$/;
		next if (not defined $1);
		$dscdir = "${outdir}/$1";
	}
	$dscdir =~ s/\.orig//;
	$dscdir =~ s/_/-/;
	my $output = `dget -ux file://$s`;
	print $output if ($verbose >= 2);
	print "Working in:$dscdir\n" if ($verbose >= 2);
	die "Unable to find the unpacked source directory.\n" if (not -d $dscdir);
	chdir ($dscdir);
	# write out debian/files
	open (FILES, ">debian/files") or die ("Cannot write debian/files: $!\n");
	print FILES @files_content;
	close (FILES);
	print "DEB_HOST_ARCH=$arch dpkg-genchanges > $changes\n";
	$retval = system ("DEB_HOST_ARCH=$arch dpkg-genchanges > $changes");
	chdir ("../");
	system ("rm -rf $dscdir");
	chdir ($olddir);
}

exit ($retval);

sub usageversion {
	print(STDERR <<END)
$progname version $our_version

Usage:
 $progname [-v|--verbose] [-q|--quiet] [-o|--outdir] PACKAGE ...
 $progname -?|-h|--help|--version

Generates a TDeb package from a .deb package by unpacking, relocating
particular classes of files and repacking with a note in the 
description and the +t1 version suffix.

If --outdir is not specified, the converted package(s) will be
created in \$TMPDIR.

When creating a TDeb repository, it is strongly
recommended to specify .changes files so that the repository
can include the original sources, for legal reasons.

Note that $progname is not much more than a quick hack right now,
it needs to be refined to be usable to translators but to do that,
the actual Debian package needs to support the TDeb in the first
place.

END
	or die "$0: failed to write usage: $!\n";
}

sub create_tmpdir {
	my $name = shift;
	my $pd = $ENV{'TMPDIR'} && -d $ENV{'TMPDIR'}
		? $ENV{'TMPDIR'}
		: '/tmp';
	return undef unless -d $pd;
	my $dir;

	eval { $dir = tempdir("$name.XXXXXXXX", DIR => $pd) };
	print("$@"), return undef if $@;

	return $dir;
}

sub fail {
	system("rm -rf $tmpdir");
	$SIG{'INT'} = 'DEFAULT';
	warn "$progname: conversion of $package failed.\n" unless $nofailmsg;
	return undef;
}

sub build_tdeb {
	my @cmds=();
	my $topdirprefix="$src/debian/${source}-locale";
	my $mainpackage = $source;
	# dirty hacks
	system ("mkdir -p $topdirprefix/usr/share/locale/");
	system ("mv $src/usr/share/locale/* $src/debian/${source}-locale/usr/share/locale/")
		if (-d "$src/usr/share/locale/");
	system ("cat $src/debian/${source}-locale/DEBIAN/control")
		if ($verbose >= 2);

	# XXX - debhelper bug. dh_builddeb fails to accept
	# XC-Package-Type: tdeb, only udeb.
	# Once debhelper fixed, remove the call to dpkg --build.
	
	print "Building ${source}-locale in $outdir\n" if $verbose >= 1;
	my $name = "$outdir/${mainpackage}-locale_${tversion}_all.tdeb";
	push @cmds, "dpkg --build ${topdirprefix} $name ";
	# add clean up commands.
#	push @cmds, "rm -rf debian/${mainpackage}-locale*";
	push @cmds, "rm -f po*/*.gmo";
	push @cmds, "rm -rf $src/debian/";
	# do the real work here.
	foreach my $cmd (@cmds)
	{
		doit ("$cmd");
	}
}

# look for and add other translated content
# needs Dpkg::Class support
sub add_content {
	my @cmds = ();
	my $topdirprefix="$src/debian/${source}-locale";
	mkdir "$src/debian";
	mkdir "${topdirprefix}/";
	mkdir "${topdirprefix}/DEBIAN/";
	open (CONTROL, ">${topdirprefix}/DEBIAN/control") or
		die ("Cannot write TDeb control file: $!\n");
	print CONTROL $newdeb;
	close (CONTROL);
	# debconf template handling - needs testing and dpkg support.
	if (-f "$src/DEBIAN/templates") {
		open (TEMPL, "$src/DEBIAN/templates") or
			die ("Cannot read DEBIAN/templates: $!\n");
		my @templates=<TEMPL>;
		close (TEMPL);
		open (DEST, ">${topdirprefix}/DEBIAN/templates") or
			die ("Cannot write destination DEBIAN/templates: $!\n");
		print DEST @templates;
		close (DEST);
		unlink ("$src/DEBIAN/templates");
	}
	my $contentprefix = "usr/share/"; # tdeb content should always be usr/share ?
	my $location = "$src/${contentprefix}";
	my $destination = "${topdirprefix}/${contentprefix}";
	my @contentlist = qw: man info :;
	foreach my $dir (@contentlist) {
		next if (! -d "$location$dir");
		opendir (CONTENT, "$location$dir")
			or die ("Unable to open existing directory $location$dir: $!\n");
		my @files=grep(!/^\.\.?$/, readdir (CONTENT));
		closedir (CONTENT);
		foreach my $cdir (@files) {
			my $clocation = "$location${dir}/$cdir";
			my $cdestination = "$destination${dir}/$cdir";
			# skip untranslated content
			next if ($cdir =~ /^man[0-9]$/);
			push @cmds, "install -d $cdestination";
			opendir (TRANS, "$clocation/");
			my @tdirs=grep(!/^\.\.?$/, readdir (TRANS));
			closedir (TRANS);
			foreach my $tdir (@tdirs) {
				my $tlocation = "$clocation/$tdir";
				my $tdestination = "$cdestination/$tdir";
				next if (-f "$tlocation");
				push @cmds, "install -d $tdestination";
				opendir (FILES, "$tlocation");
				my @tfiles=grep(!/^\.\.?$/, readdir (FILES));
				closedir (FILES);
				foreach my $tfile (@tfiles) {
					my $code = $tlocation;
					$code =~ m:$dir/(.*)/$dir[0-9]:;
					print "Relocating $1 translation of $tfile into TDeb".
						": ${source}-locale\n" if ($verbose >= 2);
					# install the translated file in the TDeb
					push @cmds, "install -m 0644 $tlocation/$tfile $tdestination";
					# take the translated file out of the binary
					push @cmds, "rm -f $tlocation/$tfile";
				}
			}
			# now remove the directory stub
			push @cmds, "rm -rf $clocation/";
		}
	}
	# do the real work here.
	foreach my $cmd (@cmds) {
		doit ("$cmd");
	}
}

sub build {
	$package = shift(@_);
	my $debpath = shift(@_);

	# first of all, check if the file exists
	if (not -r $package) {
		warn "$progname: cannot access $package: $!\n";
		return "";
	}

	print "Converting: $package\n" if $verbose >= 2;
	$nofailmsg = 0;

	# set the umask (it may be bad by default)
	umask(0022);

	$tmpdir = &create_tmpdir('splitout_tdeb');
	if (!$tmpdir) {
		warn "$progname: failed to create temporary directory: $!\n";
		return undef;
	}
	($src, $dst) = ("$tmpdir/src", "$tmpdir/dst");
	if (!(mkdir("$tmpdir/src") && mkdir("$tmpdir/dst"))) {
		warn "$progname: failed to prepare temporary directory: $!\n";
		system("rm -rf $tmpdir");
		return undef;
	}

	# remove tmp files on C-c
	$SIG{'INT'} = sub {
		print "Removing tmp files...\n" if $verbose >= 2;
		system "rm -rf $tmpdir";
		die "Interrupted.\n";
	};

	print "Extracting $package\n" if $verbose >= 2;

	# extract package to $src
	if (system("dpkg --extract $package $src && dpkg --control $package $src/DEBIAN") != 0) {
		return &fail();
	}

	print "Extracting information from control file\n" if $verbose >= 2;

	# extract useful information from control file
	if (!(open(CONTROL, "$src/DEBIAN/control"))) {
		warn "$progname: cannot open package control file: $!\n";
		return &fail();
	}

	# write useful info into destination control file.
	if (!(open(DST, ">$dst/control"))) {
		warn "$progname: cannot write package control file: $!\n";
		return &fail();
	}
	my $field;
	my %control;
	while (<CONTROL>) {
		# size will be calculated later.
		next if (/^Installed-Size:\s*[0-9]+$/i);
		print DST $_;
		chomp;
		if (/^ /) {
			$control{$field} .= ("\n" . $_) if (defined($field));
		} elsif (/^(\S+):\s*(.*)$/i) {
			$field = lc($1);
			$control{$field} = $2;
		}
	}
	close(CONTROL);
	close (DST);

	# check for existance of required fields
	for $field (qw(package version architecture)) {
		if (!defined($control{$field})) {
			warn "$progname: required field \'$field\' missing in control file\n";
			return &fail();
		}
	}

	# check for package already processed by dpkg-cross, or created by
	# cross-gcc compilation
	if (($control{"architecture"} eq "all") and (
		($control{"description"} =~ /generated by dpkg-cross/) or
		($control{"description"} =~ /contains files for.*cross-compile/)
		)) {
		warn "$progname: $package looks like a cross-compile package\n";
		return &fail();
	}

	if (! mkdir("$dst/DEBIAN")) {
		warn "$progname: failed to create $dst/DEBIAN: $!\n";
		return &fail();
	}

	# Need a way to convert a Debian TDeb to an
	# Emdebian one. 
	if ((-d "$src/usr/share/locale/") or (-d "$src/usr/share/man/") or
		(-d "$src/usr/share/info/") {
		&add_content;
		&build_tdeb;
	}

	# /usr/share/locale/ needs to be removed from the original
	system ("rm -rf $src/usr/share/locale");
	my $size = `du -kc $src | grep total | cut -d't' -f1`;
	chomp ($size);
	$size =~ s/\s+//g;

	# Create the control file.
	print "Creating control file\n" if $verbose >= 2;
	if (! open(CONTROL, ">$dst/DEBIAN/control")) {
		warn "$progname: failed to open $dst/DEBIAN/control for writing: $!\n";
		return &fail();
	}
	my $no_epoch = $control{'version'};
	$no_epoch =~ s/[0-9]://;
	$control{'version'}=$no_epoch;

	print CONTROL "Package: $control{'package'}\n";
	if (defined($control{"source"})) {
		# cope with existing versioned source listing (libgcc1)
		my $ctrl = ($control{'source'} !~ /\(.+\)/) ?
			"Source: $control{'source'} ($control{'version'})\n"
			: "Source: $control{'source'}\n";
		print CONTROL $ctrl;
	} else {
		my $ctrl = ($control{'package'} !~ /\(.+\)/) ?
			"Source: $control{'package'} ($control{'version'})\n"
			: "Source: $control{'package'}\n";
		print CONTROL $ctrl;
	}
	my $v = ($control{'version'} =~ /\Q+t1\E$/) ?
		"Version: $control{'version'}\n" :
		"Version: $control{'version'}+t1\n";
	print CONTROL $v;
	print CONTROL "Architecture: $control{'architecture'}\n";

	print CONTROL "Maintainer: $control{'maintainer'}\n"
		if (defined($control{"maintainer"}));
	print CONTROL "Installed-Size: $size\n";
	print CONTROL "Pre-Depends: $control{'pre-depends'}\n"
		if (defined($control{"pre-depends"}));
	print CONTROL "Depends: $control{'depends'}\n"
		if (defined($control{"depends"}));
	print CONTROL "Replaces: $control{'replaces'}\n"
		if (defined($control{"replaces"}));
	print CONTROL "Provides: $control{'provides'}\n"
		if (defined($control{"provides"}));
	print CONTROL "Conflicts: $control{'conflicts'}\n"
		if (defined($control{"conflicts"}));
	print CONTROL "Section: $control{'section'}\n";
	print CONTROL "Priority: $control{'priority'}\n";
	print CONTROL "Recommends: $control{'recommends'}\n"
		if (defined($control{"recommends"}));
	print CONTROL "Suggests: $control{'suggests'}\n"
		if (defined($control{"suggests"}));

	$control{"description"} .= "\n .\n This package has ".
		" been converted to support a TDeb.\n See $progname (1)\n";

	# Output modified description
	$control{"description"} =~ /(.*)/; # match first line
	print CONTROL "Description: $1 (converted)";
	print CONTROL " $'\n";
	close (CONTROL);

	# check package architecture
	my $control_arch = $control{"architecture"};

	# prepare destination filename
	my $tvers = ($control{'version'} =~ /\Q+t1\E$/) ?
		$control{"version"} : $control{"version"}."+t1";
	# strip epoch for filename
	$tvers =~ s/^\d+://;
	$debname = $control{"package"} . "_" . $tvers . "_".$control_arch.".deb";
	system ("mv $dst/DEBIAN/control $src/DEBIAN/control");

	system ("cat $src/DEBIAN/control") if ($verbose >= 2);
	# Find out if fakeroot is needed and if it is available
	my $wrapper = "";
	if (geteuid() != 0) {
		$wrapper = "/usr/bin/fakeroot";
		if (! -x $wrapper) {
			warn "$progname: $wrapper is not available, package files will not be owned by root\n";
			$wrapper = "";
		}
	}

	# Build the .deb
	print "Building $debname in $debpath\n" if $verbose >= 1;
	if (system( "$wrapper dpkg-deb -b $src ${debpath}/$debname")) {
		warn "$progname: building package with dpkg-deb -b failed.\n";
		return &fail();
	}

	$SIG{'INT'} = 'DEFAULT';
	system "rm -rf $tmpdir";
	return $debname;
}
