#!/usr/bin/perl

=pod

=head1 Name

emdebcheck - Check Emdebian builds with edos-debcheck before upload

=head1 Copyright and Licence

 Copyright (C) 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 Cwd;
use Encode;
use Config::Auto;
use File::HomeDir;
use File::Basename;
use Text::Wrap;
use Cache::Apt::Package;
use Cache::Apt::Config;
use Cache::Apt::Lookup;
use File::Spec;
use Emdebian::Tools;
use Term::ANSIColor qw(:constants);
use Debian::DpkgCross;
use strict;
use warnings;
use vars qw/$workdir $msg $arch $progname $our_version $package $verbose
 $suite $cache $name @filelist /;

$progname = basename($0);
$our_version = &tools_version();
$verbose = 1;
# read emsource config file.
$workdir = &get_workdir;
$workdir = "/" if ($workdir eq "");
$workdir.= "/trunk/";
$workdir =~ s://:/:;
&read_config();
$arch = &get_architecture();
$suite = &get_targetsuite();

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

Usage:
$progname [-v] [-q] [-a|--arch ARCH] FILENAME
$progname -?|-h|--help|--version

Options:
 -a|--arch ARCH:          Set architecture (default: defined by dpkg-cross)
 -v|--verbose:            Be verbose (repeat for more verbosity)
 -q|--quiet:              Be quiet [default]

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

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 (/^(-a|--arch)$/) {
		$arch = shift(@ARGV);
	}
	elsif (/^-$/) {
		@ARGV=split(/ /,<STDIN>);
	}
	else
	{
		&usageversion();
		die RED, "unrecognised option:  $_.", RESET . "\n";
	}
}

foreach my $file (@ARGV)
{
	chomp($file);
	if (! $file)
	{
		&usageversion;
		print RED, "Please specify a package filename to check.\n\n", RESET;
		exit (1);
	}
	$package = (File::Spec->file_name_is_absolute($file)) ? $package = $file :
		$package = File::Spec->rel2abs($file);
	if (! -f $package)
	{
		&usageversion;
		die RED, "Cannot find '$package'".RESET.".\n\n";
	}
	if ($file =~ /\.changes$/)
	{
		# convert a .changes file to an array of .deb
		my @debs = `dcmd ls $file  2>/dev/null | grep '\.deb\$'`;
		chomp (@debs);
		foreach my $d (@debs)
		{
			print "Adding $d from $file.\n" if ($verbose >= 2);
			push @filelist , $d if (-f $d);
			push @filelist, dirname($package)."/$d" if (-f dirname($package)."/$d");
		}
	}
	else
	{
		push @filelist, $package;
	}
}

my $target_gnu_type = &check_cache_arch($arch);
if ((not defined $arch)||($arch eq "")||(not defined $target_gnu_type))
{
	&usageversion;
	$msg = "\n$progname: Cannot determine the architecture to build";
	$msg .= " and no default architecture found.";
	$msg .= " Please use '$progname --arch ARCH'.\n";
	die RED, wrap('','',$msg), RESET, "\n";
}

my $quiet = "";
$quiet = "-q" if ($verbose < 1);
$cache = &get_aptcross_dir;
my @namelist = ();
foreach my $n (@filelist)
{
	print GREEN, "checking for '$n'.\n", RESET if ($verbose >= 1);
	die (RED, "Cannot find '$n'\n", RESET) if (! -f $n);
	$name = `dpkg -f $n Package`;
	chomp($name);
	push @namelist, $name
}
$name = join (" ", @namelist);
&set_verbose($verbose);
&set_suite($suite);

$msg = &check_workdir($workdir);
die $msg if ($msg ne "");
chdir ("$workdir") if ($workdir ne ".");

if (not -d "$cache/host")
{
	# have to duplicate them or use sudo.
	mkdir ("$cache/host") or die ("Unable to create the host cache directory: $!");
	open (STATUS, ">$cache/host/status");
	close (STATUS);
	mkdir "$cache/host/$suite";
	mkdir "$cache/host/$suite/lists";
	mkdir "$cache/host/$suite/lists/partial";
}
open (SOURCE, ">$cache/host/sources.compare.$suite")
	or die ("Cannot create sources list: $!");
print SOURCE "deb http://www.emdebian.org/emdebian/ unstable main\n";
print SOURCE "deb-src http://www.emdebian.org/emdebian/ unstable main\n";
close (SOURCE);

&set_cachedir("$cache/host");
&use_mysources("sources.compare.$suite");
&force_update;
my $config = &init_cache($verbose);

my %h = ();
my $iter = &get_cache_iter();
my $pkg;
do {
	$pkg = $iter->next;
	$h{$pkg}++ if ($pkg);
} while ($pkg);

my @package_names = sort (keys %h);
my $file = `mktemp -t edosXXXXXX` or die ("unable to create temp file.\n");
chomp($file);
print GREEN, "Using temporary file: $file\n" if ($verbose >= 1);
open (TEMP, ">$file") or die (RED, "Cannot open $file: $!".RESET."\n");
foreach my $p (@package_names)
{
	my $emp = AptCrossPackage->new();
	$emp->Package($p);
	$emp = &lookup_pkg($emp);
	next unless ($$emp->Version);
	next if ($name =~ /\Q$p\E/);
	print TEMP get_cache_control($emp);
}
foreach my $pkg (@filelist)
{
	print TEMP &get_package_data($pkg);
}
close TEMP;

print CYAN, "Found " . scalar (@package_names) . " package names.\n", RESET
	if ($verbose >= 1);

&edos;

exit (0);

sub get_cache_control
{
	my $emp = shift;
	my $file = "Package: " . $$emp->Package . "\n" if ($$emp->Package);
	$file .= "Source: " . $$emp->Source . "\n"
		if (($$emp->Source) && ($$emp->Source ne $$emp->Package));
	$file .= "Version: " . $$emp->Version . "\n" if ($$emp->Version);
	$file .= "Architecture: " . $$emp->Architecture . "\n" if ($$emp->Architecture);
	my $dep = $$emp->Depends;
	if ($$emp->Provides)
	{
		# AptPkg::Dep::Or dependencies are borked in Cache::Apt::* 
		# and I can't work out how to handle OR so this hack is just to prevent
		# unnecessary work by forcing debconf-2.0 | debconf.
		my $hackalert = "";
		$hackalert = ", debconf" if ($$emp->Provides =~ /debconf-2.0/);
		$file .= "Provides: " . $$emp->Provides . "$hackalert\n";
	}
	my $deps;
	my $line = "";
	my @a=();
	foreach my $d (@$dep)
	{
		$deps = $$d->Type . ": ";
		$line .= $$d->Package . " (" . $$d->VersionLimit . ")" if ($$d->VersionLimit);
		# AptPkg::Dep::Or dependencies are borked in Cache::Apt::* 
		# and I can't work out how to handle OR so this hack is just to prevent
		# unnecessary work by forcing debconf-2.0 | debconf.
		$line =~ s/debconf/debconf-2.0 \| debconf/ if ($line !~ /[a-z]debconf/);
		$line =~ s/\s\s+/ /g;
		push @a, $line if ($line ne "");
		undef ($deps) if ($line eq "");
		$line="";
	}
	$file .= $deps . join(", ",@a) . "\n" if (defined($deps));
	return "$file\n";
}

sub get_package_data
{
	$package = shift;
	die (RED, "Cannot find '$package' in ".cwd.RESET."\n") if (! -f $package);
	my $data = "\n";
	my $pkg = "Package: " . `dpkg -f $package Package`;
	chomp ($pkg);
	print GREEN, "Adding control data for '$pkg'\n", RESET if ($verbose >= 2);
	$data .= $pkg;
	$data .= "\nVersion: " . `dpkg -f $package Version`;
	$data .= "Architecture: " . `dpkg -f $package Architecture`;
	my $dep = `dpkg -f $package Depends`;
	my $predep = `dpkg -f $package Pre-Depends`;
	my $prov = `dpkg -f $package Provides`;
	my $repl = `dpkg -f $package Replaces`;
	my $confl = `dpkg -f $package Conflicts`;
	chomp($dep);
	chomp($predep);
	chomp($prov);
	chomp($repl);
	chomp($confl);
	if ($predep ne "")
	{
		$data .= "Pre-Depends: " . $predep . "\n";
		print GREEN, "Adding Pre-Depends data: '$predep'\n", RESET
			if ($verbose >= 2);
	}
	if ($dep ne "")
	{
		$data .= "Depends: " . $dep . "\n";
		print GREEN, "Adding Depends data: '$dep'\n", RESET if ($verbose >= 2);
	}
	if ($prov ne "")
	{
		$data .= "Provides: " . $prov . "\n";
		print GREEN, "Adding Provides data:'$prov'\n", RESET if ($verbose >= 2);
	}
	if ($repl ne "")
	{
		$data .= "Replaces: " . $repl . "\n";
		print GREEN, "Adding Replaces data:'$repl'\n", RESET if ($verbose >= 2);
	}
	if ($confl ne "")
	{
		$data .= "Conflicts: " . $confl . "\n";
		print GREEN, "Adding Conflicts data:'$confl'\n", RESET if ($verbose >= 2);
	}
	return $data;
}

sub edos
{
	my $version = `dpkg -f $package Version`;
	chomp($version);
	print GREEN, wrap('','',"Running edos-debcheck for $name ($version)\n"), RESET
		if ($verbose >= 1);
	my $edos = `edos-debcheck $name -explain -failures < $file 2>/dev/null`;
	my @output = split('\n', $edos);
	print @output if ((@output) and ($verbose >= 3));
	my ($fail, $excuse);
	foreach my $line (@output)
	{
		if (defined $fail)
		{
			next if ($fail =~ /\Q$line\E/);
		}
		$fail .= "$line\n" if ($line =~ /(.*):\sFAILED$/);
		$excuse .= "$line\n" if ($line =~ /^\s/);
	}
	# for some reason, unlink can fail for this file.
	my $test = unlink($file);
	system("rm $file") if ($test == 0);
	if ((defined $fail) && (defined $excuse))
	{
		# drop unprintable characters (still need to use ANSI_COLORS_DISABLED
		# to remove escape sequences if appending to a text log).
		$fail = encode("UTF-8", $fail);
		my $logdir = dirname ($package);
		my $default = "edos-debcheck revealed a problem with this build, the package ";
		$default .= "should not be uploaded until the dependencies are fixed.\n";
		$default .= "Explanation follows:\n";
		open (FLAG, ">>$logdir/emrecent_error.log") or 
			die ("$default\n$fail\n$excuse\n".
			"In addition, $progname cannot create log file in $logdir: $!");
		print FLAG "$fail\n$excuse\n";
		print FLAG `date`;
		close FLAG;
		die (RED, "\n$fail\n$excuse", RESET, "\n");
	}
	print GREEN, wrap('','',"Success: edos-debcheck finished.\n"), RESET
		if ($verbose >= 1);
}

=head1 Usage

 emdebcheck [-a|--arch ARCH] FILENAME
 emdebcheck -?|-h|--help|--version

=head1 Options

 -a|--arch ARCH:          Set architecture (default: defined by dpkg-cross)

=head1 Description

emdebcheck is similar to the debcheck routines in Debian, except this is run
before the upload is made.

Whilst native packages can (more or less) rely on pbuilder to ensure that
dependencies are actually available prior to the upload, cross builds use
build dependencies from Debian but get uploaded to a separate repository so
there is no guarantee that the dependencies generated using -cross packages
during the build are actually present in the Emdebian repository, even when
the package is cross built within a chroot.

emdebcheck attempts to cover this gap by parsing the dependency information
from the built package, inserting this data into a copy of the apt cache
for the Emdebian target repository (replacing any data from the current package)
and runs the modified cache data against 'edos-debcheck'.

Note that some packages will <B>always</B> be broken - particularly
-dev packages. Errors are output to the emrecent error logfile - fix the
issue(s) and remove the error log before trying to upload this package
using emrecent.

=head1 Use in pipes

emdebcheck can also read filenames from STDIN, use:
 emdebcheck -
at the end of your pipe.

You can parse a .changes with the 'dcmd' tool from devscripts:
 dcmd ls -1 /$path/foo_vers_arm.changes | grep '.deb$' | grep -v '\-dev_' | sed 'N;s/\n/ /' | emdebcheck -

Note the removal of the -dev package, depending on the source package, you may
also want to remove other packages from the list output by dcmd.

When emdebcheck is passed more than one file <B>these must all
be from the same source package<B> - i.e. scripts can parse the .changes
file, identify the .deb packages and pass them all to emdebcheck. This is
supported so that a binary like bzip2 can be checked alongside the library
that is built from the same source (libbz2-1.0) as both will be uploaded
together, e.g. by emrecent. emrecent also removes -dev packages that are
always likely to fail.

=cut