#!/usr/bin/perl

=head1 NAME

emgrip - converts a .deb to Emdebian Grip on-the-fly

=cut

=head1 Synopsis

 DEB_BUILD_OPTIONS='usegrip' emgrip [-v|--verbose] [-q|--quiet] [-o|--outdir DIRECTORY] FILENAME

where FILENAME is a .dsc, a .changes or a .deb

 emgrip -?|-h|--help|--version

=cut

=head1 Description

Converts a .deb package to Emdebian Grip by unpacking, pruning
particular classes of files (determined by DEB_BUILD_OPTIONS)
and repacking with a shortened description and the em1 version
suffix.

When creating a public Emdebian Grip repository, it is strongly
recommended to specify .changes or .dsc files to allow the generation
of Emdebian TDebs from the source package as well as including the
source package itself in the repository.

In .dsc mode, C<emgrip> only processes the source package, as of
version 3.0.0

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-2010  Neil Williams <codehelp@debian.org>
 Copyright (C) 2005 Joey Hess <joeyh@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 Cwd 'realpath';
use POSIX;
use POSIX qw(:errno_h :signal_h);
use POSIX qw(locale_h);
use Locale::gettext;
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 $nolintian
%options $essential $docs %files $help @filelist %origdirs $vendor
@src @debs @gripped $changes $arch $symbols $locale $noperl $vopts 
$vname $vshort $noscripts $base_arch /;

setlocale(LC_MESSAGES, "");
textdomain("emdebian-grip");

$progname = basename ($0);
$verbose = 1;
$our_version = &scripts_version();
$vendor = $ENV{"DEB_VENDOR"} if (defined $ENV{"DEB_VENDOR"});
$base_arch = `LC_ALL=C dpkg-architecture -qDEB_HOST_ARCH 2>/dev/null`;
chomp $base_arch;
@src=();
%origdirs = ();

=head1 Emdebian Grip

The idea here is based on dpkg-cross:

 1. receive .deb or .changes as a command-line option
 2. parse DEB_BUILD_OPTIONS
 3. unpack the .deb as dpkg-cross does
 4. remove files as per DEB_BUILD_OPTIONS
 5. repack the .deb with an Emdebian version suffix.
 6. build new .deb and revise .changes so that the
     original source can be retained.
 7. Include the gripped packages into a local mirror
     to reduce the size of Packages.gz and the size of
     the mirror itself.

As few dependencies as possible - this script should
become a new package and have a new set of lintian
checks to allow perl etc.

 NO FUNCTIONAL CHANGES IN THE FINAL .DEB !

Conversion of Debian TDebs to Emdebian TDebs needs to be
done inside the source package so a .changes file is needed
for this step. If the .changes file references a Debian TDeb,
emgrip will run 'em_installtdeb --no-sign' inside
the source package.

Individual packages containing translation files will have the
translation files removed and Debian TDebs are skipped.

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

Set the build options by placing a file in
F</etc/dpkg/origins/> containing the build options in a
field called C<Grip-Build-Option> and call C<emgrip> with the
C<--vendor> option or C<DEB_VENDOR> environment variable.

dpkg-vendor fields used by emgrip with default values:

 Vendor: emdebian-grip
 Vendor-Name: Emdebian Grip
 Grip-Build-Option: usegrip
 Short-Desc-Suffix: gripped

The C<Short-Desc-Suffix> is wrapped in parentheses and
appended to the short description [default is 'gripped'].

=cut

=head1 DEB_BUILD_OPTIONS

If none of these options are set, emgrip does nothing.

 nodocs

Remove all content in /usr/share/doc/*/ except the copyright
file and compress the copyright file itself. Remove manpages
and info pages (translated or not). Also remove doc-base files
that describe the documentation that no longer exists.

 nohelp

Remove even help files from all packages, including -doc packages.
Includes removing /usr/share/gtk-doc/html and
/usr/share/gnome/help/\$package
Despite removing the help files, dependencies on help file utilities
like scrollkeeper will remain, at least for Lenny.

 noessential

Remove the 'Essential: yes' tag from DEBIAN/control - this
is a brute force removal, no additional dependencies are to
be generated (no patches) so care is needed here.

 nolintian

Remove all files from /usr/share/lintian/overrides and
/usr/share/linda/overrides - saves up to 1Mb.

 usegrip

Combination flag that sets all DEB_BUILD_OPTIONS for Emdebian
Grip - noessential, nohelp, nodocs, nolintian

 nosymbols

Currently being tested - the idea is to drop DEBIAN/symbols files
but this could have unpredictable effects on packages built on a
system lacking these symbols. The space saved by dropping these files
might not be worth the cost, so 'usegrip' does not yet activate
'nosymbols'. This might be suitable for Crush, maybe not Grip.

 noperl

Remove any file that is found to be a perl script text executable
by 'file' - used by Crush.

 usecrush

Combination flag that adds nosymbols and noperl to usegrip.

 noscripts

Drop all maintainer scripts from all packages irrespective of the
type of script. Includes removing debconf templates and config scripts.
md5sums files and triggers are also removed. Scripts are moved to a
F<scripts/> subdirectory of the output directory used by C<emgrip>.

 usebaked

Combination flag that adds noscripts and nosymbols to usegrip. Add
C<noperl> to use Baked for Crush.

=cut

=head1 Field removal

Functional control fields are retained but the question arises:

 Who defines functional?

Well, for the current purposes of Emdebian Grip, functional includes
only the following control fields:

 Package
 Source
 Version
 Architecture
 Maintainer
 Installed-Size
 Depends
 Pre-Depends
 Conflicts
 Replaces
 Section
 Priority
 Description
 Task
 XS-Python-Version

Recommends is explicitly rejected, as is Suggests - the expectation
is that Emdebian Grip will disable Install-Recommends in apt anyway,
so that Gripped packages can be mixed with Debian or locally-built
packages.

Note also that 'Essential' is not preserved.

Homepage, VCS* and all X- control fields are dropped.

The net result is a (potentially) much cleaner dpkg database.

The description is trimmed to four lines (or three if the fourth line
is empty).

=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
    DEB_BUILD_OPTIONS="nodocs nohelp usegrip" ./emgrip -o $DIR $deb
 done

With C<dpkg-vendor> support, DEB_BUILD_OPTIONS can be replaced by
setting the vendor.

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

Despite using dcut internally, emgrip 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 an Emdebian Grip
repository to "catch-up" with the existing Debian mirrors, e.g. if the
first upload to the Grip repository is a binary-only upload without a
referenced .orig.tar.gz.

emgrip 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.

To ease the process of gripping an existing mirror, the
emdebian-grip-server package depends on 'reprepro' to create a filtered
Debian mirror that can be kept up to date, generates meta-data for
Emdebian Grip, builds gripped packages in an 'incoming/' directory and
includes the packages into the final Emdebian Grip repository.

Once a package has been "gripped", the binary packages could be
removed from the filtered mirror - the source packages (particularly
the .orig.tar.gz) are probably best retained in the filtered mirror.

=cut

while( @ARGV ) {
	$_= shift( @ARGV );
	last if m/^--$/;
	if (!/^-/) {
		unshift(@ARGV,$_);
		last;
	} elsif (/^(-\?|-h|--help|--version)$/) {
		&usageversion();
		exit (0);
	} elsif (/^(--vendor)$/) {
		$vendor = shift;
		if (not defined $vendor) {
			warn _g("Undefined vendor string.\n");
			next;
		}
		my $chk_vndr = `LC_ALL=C dpkg-vendor --vendor $vendor --query Grip-Build-Option 2>/dev/null`;
		if (($? != 0) or ($chk_vndr eq "\n")) {
			warn sprintf(_g("Unrecognised vendor: '%s'"), $vendor);
			undef ($vendor);
		} else {
			chomp ($chk_vndr);
			$vopts = $chk_vndr;
			$chk_vndr = `LC_ALL=C dpkg-vendor --vendor $vendor --query Vendor-Name 2>/dev/null`;
			chomp ($chk_vndr);
			$vname = $chk_vndr;
			$chk_vndr = `LC_ALL=C dpkg-vendor --vendor $vendor --query Short-Desc-Suffix 2>/dev/null`;
			chomp ($chk_vndr);
			$vshort = $chk_vndr;
		}
	} elsif (/^(-v|--verbose)$/) {
		$verbose++;
	} elsif (/^(-q|--quiet)$/) {
		$verbose--;
	} elsif (/^(-o|--outdir)$/) {
		$outdir = shift;
		die sprintf(_g("'%s' is not a directory.\n"), $outdir)
			if (not -d $outdir);
		$outdir =~ s:/$::;
		$outdir = realpath ($outdir);
		chomp ($outdir);
	} else {
		my $fail = $_;
		die sprintf(_g("%s: Unknown option: %s\n"), $progname, $fail);
	}
}

my $varg = (defined $vendor) ? "--vendor $vendor" : "";
my $chk_vndr = `LC_ALL=C dpkg-vendor $varg --query Grip-Build-Option 2>/dev/null`;
if (($? != 0) or ($chk_vndr eq "\n")) {
	undef $vendor;
} else {
	chomp ($chk_vndr);
	$vopts = $chk_vndr;
	$chk_vndr = `LC_ALL=C dpkg-vendor $varg --query Vendor-Name 2>/dev/null`;
	chomp ($chk_vndr);
	$vname = $chk_vndr;
	$chk_vndr = `LC_ALL=C dpkg-vendor $varg --query Short-Desc-Suffix 2>/dev/null`;
	chomp ($chk_vndr);
	$vshort = $chk_vndr;
}

if (defined $vopts) {
	my @opt = split (" ", $vopts);
	foreach my $o (@opt) {
		$options{$o}++;
	}
}

if (defined $ENV{"DEB_BUILD_OPTIONS"}) {
	my @opt = split (" ", $ENV{"DEB_BUILD_OPTIONS"});
	foreach my $o (@opt) {
		$options{$o}++;
	}
}

die sprintf(_g("%s: Please specify some packages to take into a grip.\n"),
	$progname) 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}++;
}

# convert DEB_BUILD_OPTIONS into simple values.
$options{'usegrip'}++ if (defined $options{'usebaked'});
$options{'usegrip'}++ if (defined $options{'usecrush'});
$essential++ if ((defined $options{'noessential'}) or
	(defined $options{'usegrip'}));
$nolintian++ if ((defined $options{'nolintian'}) or
	(defined $options{'usegrip'}));
$docs++ if ((defined $options{'nodocs'}) or
	(defined $options{'usegrip'}));
$help++ if ((defined $options{'nohelp'}) or
	(defined $options{'usegrip'}));
$symbols++ if ((defined $options{'nosymbols'}) or
	(defined $options{'usecrush'}) or
	(defined $options{'usebaked'}));
$locale++ if ((defined $options{'usegrip'}) or
	(defined $options{'usecrush'}));
$noperl++ if ((defined $options{'noperl'}) or
	(defined $options{'usecrush'}));
$noscripts++ if ((defined $options{'nosymbols'}) or
	(defined $options{'usebaked'}));
if (defined $options{'usebaked'}) {
	system ("mkdir -p $outdir/scripts");
}

if (defined $options{'usecrush'}) {
	$chk_vndr = `LC_ALL=C dpkg-vendor --vendor emdebian-crush --query Vendor-Name 2>/dev/null`;
	chomp ($chk_vndr);
	$vname = $chk_vndr;
	$chk_vndr = `LC_ALL=C dpkg-vendor --vendor emdebian-crush --query Short-Desc-Suffix 2>/dev/null`;
	chomp ($chk_vndr);
	$vshort = $chk_vndr;
}

if (defined $options{'usebaked'}) {
	$chk_vndr = `LC_ALL=C dpkg-vendor --vendor emdebian-baked --query Vendor-Name 2>/dev/null`;
	chomp ($chk_vndr);
	$vname = $chk_vndr if (defined $chk_vndr);
	$chk_vndr = `LC_ALL=C dpkg-vendor --vendor emdebian-baked --query Short-Desc-Suffix 2>/dev/null`;
	chomp ($chk_vndr);
	$vshort = $chk_vndr if (defined $chk_vndr);
}

# nothing to do if no options set.
exit 0 if ((not defined $essential) or (not defined $docs) or
	(not defined $help));

# ensure unique package names.
foreach $package ( @ARGV ) {
	if ($package =~ /\.tdeb$/) {
		my $fail = $_;
		printf( _g("'%s' is a Debian tdeb which cannot be gripped by %s.\n"),
			$fail, $progname);
		exit 0;
	}
	$package = realpath ($package);
	chomp ($package);
	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 ($d =~ /\.tdeb$/) {
				printf( _g("Skipping TDeb '%s' from %s.\n"), $d, $package)
					if ($verbose >= 2);
				next;
			}
			if (-f "$d") {
				printf( _g("Adding %s from %s.\n"), $d, $package)
					if ($verbose >= 2);
				push @filelist, $d;
			}
		}
	} elsif ($package =~ /\.dsc$/) {
		@src = `LC_ALL=C dcmd ls -1 $package 2>/dev/null | grep -vE '\.[t|u]?deb\$'`;
		chomp (@src);
		$changes = "$outdir/" . basename($package);
		# this file might not exist but it will be regenerated.
		$changes =~ s/\.dsc$/_${base_arch}.changes/;
	} else {
		printf( _g("Adding %s from %s.\n"), $package, $package)
			if ($verbose >= 2);
		push @filelist, $package;
	}
}

foreach $package ( @filelist ) {
	$builds{"$package"}++;
}

# copy sources over to $outdir
foreach my $s (@src) {
	my $sfile = basename ($s);
	open (SRC, "$s") or die (_g("Cannot open")." $s: $!\n");
	my @cont=<SRC>;
	close (SRC);
	open (DEST, ">$outdir/$sfile") or
		die (_g("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);

my @files_content;
# prepare debian/files content
foreach my $d (@gripped) {
	my $files_priority = `LC_ALL=C dpkg-deb -f $outdir/$d Priority`;
	my $files_section  = `LC_ALL=C dpkg-deb -f $outdir/$d Section`;
	$arch = `LC_ALL=C 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);
	my $srcpkg = `grep Source: $s`;
	$srcpkg =~ s/^Source: (.*)$/$1/;
	chomp ($srcpkg);
	open (DSC, "$s") or die (_g("Cannot read")." $s: $!\n");
	my @dsclines=<DSC>;
	close (DSC);
	foreach my $l (@dsclines) {
		$l =~ /.* (.*)[\.orig]?\.tar\.(gz|bz2)$/;
		next if (not defined $1);
		$dscdir = "${outdir}/$1";
	}
	my $dsc_check = $dscdir;
	$dscdir =~ s/\.orig//;
	$dscdir =~ s/_/-/;
	my $output = `dget -ux file://$s`;
	print $output if ($verbose >= 2);
	if (not -d "$dscdir") {
		$dscdir = $dsc_check;
		$dscdir =~ s/\.orig//;
		$dscdir =~ s/(.*${srcpkg}_.*)-.*$/$1/;
		$dscdir =~ s/_/-/;
		die _g("Unable to find the unpacked source directory:")." $dscdir.\n"
			if (not -d "$dscdir");
	}
	printf( _g("Working in: %s\n"), $dscdir) if ($verbose >= 2);
	chdir ($dscdir);
	system ("em_installtdeb --no-sign");
	# write out debian/files
	open (FILES, ">debian/files") or die (_g("Cannot write")." debian/files: $!\n");
	print FILES @files_content;
	close (FILES);
	printf( _g("INF: Generating changes file for %s\n"), $base_arch);
	$retval = system ("dpkg-genchanges 2>/dev/null 1> $changes");
	chdir ("../");
	system ("rm -rf $dscdir");
	chdir ($olddir);
}

exit ($retval);

sub usageversion {
	printf STDERR (_g("
%s version %s

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

Converts a .deb package to Emdebian Grip by unpacking, pruning
particular classes of files (determined by DEB_BUILD_OPTIONS)
and repacking with the em1 version suffix.

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

When creating a public Emdebian Grip repository, it is strongly
recommended to specify .changes files to allow the generation of
Emdebian TDebs from the source package as well as including the
source package itself in the repository.

If no options are set for DEB_BUILD_OPTIONS, %s does
nothing. Accepted options are:

'nodocs', 'nohelp' or 'noessential'. Pass 'usegrip' to set all
accepted options in one. See %s (1) for details of each
option.

"), $progname, $our_version, $progname, $progname, $progname, $progname)
	or die "$0: "._g("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 sprintf(_g("%s: conversion of %s failed.\n"),
		$progname, $package) unless $nofailmsg;
	return undef;
}

sub build {
	my %prunable=();
	my @candidates=();
	$package = shift(@_);
	my $debpath = shift(@_);
	# first of all, check if the file exists
	if (not -r $package) {
		warn sprintf(_g("%s: cannot access %s:"), $progname, $package)." $!\n";
		return "";
	}
	if ($verbose >= 2) {
		if (defined $vname) {
			printf( _g("Taking a grip on: '%s' for %s"), $package, $vname);
		} else {
			printf( _g("Taking a grip on: '%s'"), $package);
		}
		print ".\n";
	}
	$nofailmsg = 0;
	# set the umask (it may be bad by default)
	umask(0022);
	$tmpdir = &create_tmpdir('emgrip');
	if (!$tmpdir) {
		warn "$progname: "._g("failed to create temporary directory").": $!\n";
		return undef;
	}
	my ($src, $dst) = ("$tmpdir/src", "$tmpdir/dst");
	if (!(mkdir("$tmpdir/src") && mkdir("$tmpdir/dst"))) {
		warn "$progname: "._g("failed to prepare temporary directory").": $!\n";
		system("rm -rf $tmpdir");
		return undef;
	}
	# remove tmp files on C-c
	$SIG{'INT'} = sub {
		print _g("Removing tmp files...\n") if $verbose >= 2;
		system "rm -rf $tmpdir";
		die _g("Interrupted.\n");
	};
	printf( _g("Extracting %s\n"), $package) if $verbose >= 2;
	# extract package to $src
	if (system("dpkg --extract $package $src && dpkg --control $package $src/DEBIAN") != 0) {
		return &fail();
	}
	# get a list of directories that are intentionally empty.
	my @safe=`find $src -type d -empty`;
	foreach my $s (@safe) {
		chomp ($s);
		$origdirs{$s}++;
	}
	print _g("Extracting information from control file\n") if $verbose >= 2;
	# extract useful information from control file
	if (!(open(CONTROL, "$src/DEBIAN/control"))) {
		warn "$progname: "._g("cannot open package control file").": $!\n";
		return &fail();
	}
	unlink ("$src/DEBIAN/symbols") if ((-f "$src/DEBIAN/symbols")
		and (defined ($symbols)));
	if (defined ($noscripts)) {
		my @scripts = qw/ config templates postinst postrm preinst prerm
		conffiles md5sums triggers shlibs /;
		foreach my $s (@scripts) {
			if (-f "$src/DEBIAN/$s") {
				open (SCRIPT, "$src/DEBIAN/$s") or die ("Cannot open $s");
				my @scr=<SCRIPT>;
				close (SCRIPT);
				open (BAKED, ">$outdir/scripts/$package.$s");
				print BAKED @scr;
				close (BAKED);
				unlink ("$src/DEBIAN/$s");
			}
		}
	}
	# write useful info into destination control file.
	if (!(open(DST, ">$dst/control"))) {
		warn "$progname: "._g("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);
		next if ((/^Essential:\s*yes\s*$/i) and (defined $essential));
		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})) {
			my $msg = sprintf(_g("%s: required field \'%s\' missing in control file\n"),
				$progname, $field);
			warn ($msg);
			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 sprintf(_g("%s: %s looks like a cross-compile package\n"),
			$progname, $package);
		return &fail();
	}
	if (! mkdir("$dst/DEBIAN")) {
		warn "$progname: "._g("failed to create")." $dst/DEBIAN: $!\n";
		return &fail();
	}
	# Need a way to convert a Debian TDeb to an
	# Emdebian one. Either way, /usr/share/locale/ should not be
	# retained in the gripped package.
	# EXCEPT /usr/share/locale/locale.alias
	my $dirs = &locale_dirs ($src);
	foreach my $d (@$dirs) {
		system ("rm -rf $src/usr/share/locale/$d")
			if (defined $locale);
	}
	# nolintian support
	if (defined $nolintian) {
		system ("rm -f $src/usr/share/lintian/overrides/*");
		system ("rm -f $src/usr/share/linda/overrides/*");
	}
	# noperl support
	if (defined $noperl) {
		my @candidates=`find $src |xargs file`;
		foreach my $c (@candidates) {
			my @f=split(":", $c);
			unlink $f[0] if ($c =~ m:/usr/bin/perl.*script text executable:);
			unlink $f[0] if ($c =~ /Perl5 module source text/);
		}
	}
	# nohelp support
	# remove gtk-doc/html
	system ("rm -rf $src/usr/share/gtk-doc/html") if (defined $help);
	# remove gnome/help/
	# only C/ will exist once we have TDebs.
	# but $control{'package'} could be the -doc version which does not
	# match.
	system ("rm -rf $src/usr/share/gnome/help/") if (defined $help);
	# liferea has weird /usr/share/liferea/doc/html and others might too.
	system ("rm -rf $src/usr/share/$control{'package'}/doc/html/")
		if (defined $help);
	if (defined $docs) {
		# remove usr/share/man
		system ("rm -rf $src/usr/share/man");
		# remove usr/share/info
		system ("rm -rf $src/usr/share/info");
		# remove usr/share/doc-base
		system ("rm -rf $src/usr/share/doc-base");
		my $parent = $control{'source'};
		$parent = $control{'package'} if (not defined $parent);
		$parent =~ s/ .*$//;
		system ("mv $src/usr/share/doc/$control{'package'}/copyright $dst/copyright")
			if ((-d "$src/usr/share/doc/$control{'package'}/") and
			(-f "$src/usr/share/doc/$control{'package'}/copyright"));
		system ("mv $src/usr/share/doc/$control{'package'}/copyright.gz $dst/copyright.gz")
			if ((-d "$src/usr/share/doc/$control{'package'}/") and
			(-f "$src/usr/share/doc/$control{'package'}/copyright.gz"));
		# remove usr/share/doc-base/*
		system ("rm -rf $src/usr/share/doc-base/*");
		# remove usr/share/doc/$package/*
		system ("rm -rf $src/usr/share/doc/$parent/*");
		system ("rm -rf $src/usr/share/doc/$control{'package'}/*");
		# libgconf-dev puts docs in /usr/share/doc/gconf2/
		# but the source package is 'gconf'
		system ("rm -rf $src/usr/share/doc/${parent}*/*");
		if (-f "$dst/copyright") {
			# compress copyright and move copyright.gz back.
			system ("gzip -9 $dst/copyright");
			system ("mv $dst/copyright.gz $src/usr/share/doc/$control{'package'}/copyright.gz");
		}
		system ("mv $dst/copyright.gz $src/usr/share/doc/$control{'package'}/copyright.gz")
			if (-f "$dst/copyright.gz");
	}
	my $size = `du -kc $src | grep total | cut -d't' -f1`;
	chomp ($size);
	$size =~ s/\s+//g;
	# Create the control file.
	print _g("Creating control file\n") if $verbose >= 2;
	if (! open(CONTROL, ">$dst/DEBIAN/control")) {
		my $fail = $!;
		my $msg = sprintf(_g("%s: failed to open %s/DEBIAN/control for writing: %s\n"),
			$progname, $dst, $fail);
		warn ($msg);
		return &fail();
	}
	my $no_epoch = $control{'version'};
	$no_epoch =~ s/[0-9]://;
	print CONTROL "Package: $control{'package'}\n";
	if (defined($control{"source"})) {
		# cope with existing versioned source listing (libgcc1)
		my $ctrl = ($control{'source'} !~ /\(.+\)/) ?
			"Source: $control{'source'} ($no_epoch)\n"
			: "Source: $control{'source'}\n";
		print CONTROL $ctrl;
	} else {
		my $ctrl = ($control{'package'} !~ /\(.+\)/) ?
			"Source: $control{'package'} ($no_epoch)\n"
			: "Source: $control{'package'}\n";
		print CONTROL $ctrl;
	}
	my $v = ($control{'version'} =~ /em1$/) ?
		"Version: $control{'version'}\n" :
		"Version: $control{'version'}em1\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";
	if (defined($control{"pre-depends"})) {
		# handle strictly versioned pre-depends
		if ($control{'pre-depends'} =~ / \(= /) {
			# fixup direct dependencies to match the gripped version.
			my $strict = $control{'pre-depends'};
			my @base = split(",", $strict);
			my @res = ();
			foreach my $t (@base) {
				$t =~ s/ \(= (.+)?\)/ \(= ${1}em1\)/;
				push @res, $t;
			}
			$strict =~ s/ \(= (.+)?\)/ \(= ${1}em1\)/;
			$control{'pre-depends'} = join(",",@res);
		}
		print CONTROL "Pre-Depends: $control{'pre-depends'}\n";
	}
	if (defined($control{"depends"})) {
		if ($control{'depends'} =~ / \(= /) {
			# fixup strict dependencies to match the gripped version.
			my $strict = $control{'depends'};
			my @base = split(",", $strict);
			my @res = ();
			foreach my $t (@base) {
				$t =~ s/ \(= (.+?)?\)/ \(= ${1}em1\)/g;
				push @res, $t;
			}
			$strict =~ s/ \(= (.+?)?\)/ \(= ${1}em1\)/g;
			$control{'depends'} = join(",",@res);
		}
		print CONTROL "Depends: $control{'depends'}\n";
	}
	if (defined($control{"replaces"})) {
		# allow for replacing a gripped version
		if ($control{'replaces'} =~ / \(/) {
			my $strict = $control{'replaces'};
			my @base = split(",", $strict);
			my @res = ();
			foreach my $t (@base) {
				$t =~ s/ \((.+)?\)/ \(${1}em1\)/;
				push @res, $t;
			}
			$strict =~ s/ \((.+)?\)/ \(${1}em1\)/;
			$control{'replaces'} = join(",",@res);
		}
		print CONTROL "Replaces: $control{'replaces'}\n"
	}
	if (defined($control{"conflicts"})) {
		# preserve handle versioned conflicts against gripped versions
		if ($control{'conflicts'} =~ / \(/) {
			my $strict = $control{'conflicts'};
			my @base = split(",", $strict);
			my @res = ();
			foreach my $t (@base) {
				# Conflicts with 'less than' do not need to change.
				# see libungif4g and libgif4
				$t =~ s/ \((.+)?\)/ \(${1}em1\)/
					unless ($t =~ /<</);
				push @res, $t;
			}
			$strict =~ s/ \((.+)?\)/ \(${1}em1\)/;
			$control{'conflicts'} = join(",",@res);
		}
		print CONTROL "Conflicts: $control{'conflicts'}\n"
	}
	# Support 'Provides:' (no versioning)
	print CONTROL "Provides: $control{'provides'}\n"
		if (defined($control{"provides"}));
	print CONTROL "Section: $control{'section'}\n";
	print CONTROL "Priority: $control{'priority'}\n";
	print CONTROL "Task: $control{'task'}\n"
		if (defined $control{'task'});
	print CONTROL "Python-Version: $control{'python-version'}\n"
		if (defined $control{'python-version'});
	# grip the description to 4 lines (stripping the fourth line
	# if it is empty).
	my @t = split ("\n", $control{"description"});
	my $limit = (scalar @t < 4) ? scalar @t : 4;
	$limit = 3 if ((not defined $t[$limit]) or ($t[$limit] =~ / \./));
	my $c = 0;
	my $str;
	foreach my $l (@t) {
		chomp ($l);
		$str .= $t[$c]."\n" if ($l !~ /^\s?$/);
		$c++;
	}
	$str = "";
	my @r = ();
	@r = @t[0..$limit];
	foreach my $line (@r) {
		$str .= $line."\n" if (defined $line);
	}
	chomp ($str);
	$control{"description"} = $str;
	my $t = $r[0] if (defined $r[0]);
	$t .= $r[1] if (defined $r[1]);
	$t .= $r[2] if (defined $r[2]);
	$t .= $r[3] if (defined $r[3]);
	$control{"description"} .= "\n . ...\n" if ($t !~ / \.\.\./);
	# Output modified description
	my @desclines = split("\n", $control{'description'});
	# split out the first line
	my $first = shift @desclines;
	my $rest = join ("\n", @desclines);
	if (($first !~ / \(crushed\)/) or ($first !~ / \(gripped\)/)
		or ($first != / \($vshort\)/)) {
		if (defined $vshort) {
			print CONTROL "Description: $first ($vshort)";
		} else {
			print CONTROL "Description: $first (gripped)";
		}
	} else {
		print CONTROL "Description: $first"
	}
	print CONTROL "\n$rest\n";
	close (CONTROL);
	# check package architecture
	my $control_arch = $control{"architecture"};
	# prepare destination filename
	my $evers = ($control{'version'} =~ /em1$/) ?
		$control{"version"} : $control{"version"}."em1";
	# strip epoch for filename
	$evers =~ s/^\d+://;
	$debname = $control{"package"} . "_" . $evers . "_".$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 sprintf(_g("%s: %s is not available, package files will not be owned by root\n"),
				$progname, $wrapper);
			$wrapper = "";
		}
	}
	# update the md5sums to reduce the size of that file too.
	# borrowed from dh_md5sums.
	my $exclude = "";
	if (-f "$src/DEBIAN/conffiles") {
		open (CONF, "$src/DEBIAN/conffiles") or
			die _g("Unable to read conffiles").": $!\n";
		while (<CONF>) {
			chomp;
			s/^\///;
			$exclude.="! -path \"./$_\" ";
		}
	}
	mkdir ("$src/DEBIAN")
		if (not -d "$src/DEBIAN");
	my $find = "cd $src/; ";
	$find .= "find . -type f $exclude ! -regex '.*/DEBIAN/.*' -printf '%P\\0' | ";
	$find .= "xargs -r0 md5sum > ./DEBIAN/md5sums";
	system ($find);

	# Build the .deb
	printf( _g("INF: Building %s in %s\n"), $debname, $debpath)
		if $verbose >= 1;
	if (system( "$wrapper dpkg-deb -b $src ${debpath}/$debname 1>/dev/null")) {
		warn "$progname: "._g("building package with dpkg-deb -b failed.\n");
		return &fail();
	}
	$SIG{'INT'} = 'DEFAULT';
	system "rm -rf $tmpdir";
	return $debname;
}

sub locale_dirs {
	my @dirs=();
	my $src = shift;
	opendir (LOCALE, "$src/usr/share/locale/") or return \@dirs;
	my @list=grep(!/^\.\.?$/, readdir(LOCALE));
	closedir (LOCALE);
	foreach my $file (@list) {
		push @dirs, $file if (-d "$src/usr/share/locale/$file");
	}
	return \@dirs;
}

sub scripts_version {
	my $query = `dpkg-query -W -f='\${Version}' emdebian-grip`;
	(defined $query) ? return $query : return "";
}

sub _g {
	return gettext(shift);
}