#!/usr/bin/perl

use strict;
use warnings;
use IO::File;
use File::Copy;
use File::Basename;
use POSIX qw(locale_h);
use Locale::gettext;
use Parse::Debian::Packages;
use Emdebian::Grip; # internal module
use Debian::Packages::Compare;
use IO::Uncompress::Gunzip qw(gunzip $GunzipError) ;

use vars qw/ $grip_name $suite $base $mode $package %sections
 @architectures @components %orig %dupes $arch $prog $dry $c
 @archlist $cmd $main $arch /;

setlocale(LC_MESSAGES, "");
textdomain("emdebian-grip");
$grip_name = "grip";
$suite = "unstable";
$prog = basename($0);

while( @ARGV ) {
	$_= shift( @ARGV );
	last if m/^--$/;
	if (!/^-/) {
		unshift(@ARGV,$_);
		last;
	} elsif (/^(-\?|-h|--help)$/) {
		&usageversion();
		exit (0);
	} elsif (/^(-n|--dry-run)$/) {
		$dry++;
	} elsif (/^(-b|--base-path)$/) {
		$base = shift;
	} elsif (/^(-a|--arch)$/) {
		$arch = shift;
	} elsif (/^(-m|--merge)$/) {
		die (_g("Cannot trim, merge or purge at the same time.\n"))
			if (defined $mode);
		$mode = 'merge';
		$package = \@ARGV;
		die (_g("Please specify a package to merge.\n"))
			if (not defined $package);
	} elsif (/^(-p|--purge)$/) {
		die (_g("Cannot trim, merge or purge at the same time.\n"))
			if (defined $mode);
		$mode = 'purge';
		$package = \@ARGV;
		die (_g("Please specify a package to purge (from main).\n"))
			if (not defined $package);
		last;
	} elsif (/^(-t|--trim)$/) {
		die (_g("Cannot trim, merge or purge at the same time.\n"))
			if (defined $mode);
		$mode = 'trim';
		$package = \@ARGV;
		die (_g("Please specify a package to trim (leave only in main).\n"))
			if (not defined $package);
	} elsif (/^(-s|--suite)$/) {
		$suite = shift;
	} elsif (/^(--grip-name)$/) {
		$grip_name = shift;
	} else {
		die "$prog: "._g("Unknown option")." $_.\n";
	}
}

die _g("ERR: Please specify an existing directory for the base-path.\n")
	if (not defined $base);

$base .= '/' if ("$base" !~ m:/$:);
if (not -d $base) {
	printf (_g("ERR: Please specify an existing directory for the base-path: %s\n"),$base);
	exit 1;
}

&set_base($base);
&set_repo_names (undef, $grip_name);
my $s = &get_suite_names ($grip_name);
my $a = &get_archlist ($suite, $grip_name);
if (not defined $a) {
	my $dfile = sprintf("%s/%s/conf/distributions",$base, $grip_name);
	$dfile =~ s://:/:g;
	printf (_g("ERR: Cannot retrieve distributions file: %s\n"),$dfile);
	exit 2;
}
@architectures = @$a;
$c = &get_components ($suite, $grip_name);
@components = @$c;
my $src = (find_duplicates ($suite, $grip_name));
%orig = %$src;
%dupes = ();
foreach my $pkg (sort keys %orig) {
	my $pc = 0;
	foreach my $c (@components) {
		$pc++ if (exists ($orig{$pkg}{$c}));
	}
	$dupes{$pkg} = $pc if ($pc >= 2);
}

if ((defined $mode) and ($mode eq 'merge') and (defined $package)) {
	# Translators, INF is an abbreviation of 'INFORMATION:'
	printf (_g("INF: Trying to merge %s.\n"), join (" ", @$package));
	&merge($package);
	exit 0;
}

if ((defined $mode) and ($mode eq 'purge') and (defined $package)) {
	&purge($package);
	exit 0;
}

if ((defined $mode) and ($mode eq 'trim') and (defined $package)) {
	&trim($package);
	exit 0;
}

foreach my $dup (sort keys %dupes) {
	my $str="";
	my $sec=(defined $sections{$dup}) ? $sections{$dup} : "";
	printf (_g("'%s' (Count: %d) [Section: %s]:"), $dup, $dupes{$dup}, $sec);
	foreach my $c (@components) {
		if (exists $orig{$dup}{$c}) {
			$str .= "\t$c: ".$orig{$dup}{$c}."\n";
		}
	}
	print "\n$str";
}

exit 0;

=pod

=head1 NAME

emgrip-dupes - find packages listed in more than one component

=head1 Synopsis

 Syntax: emgrip-dupes -b PATH [OPTIONS]
         emgrip-dupes -b PATH -m|--merge NAME [OPTIONS] 
         emgrip-dupes -b PATH -p|--purge NAME [OPTIONS]
         emgrip-dupes -?|-h|--help|--version

 Commands:
 -b|--base-path PATH:           path to the top level grip directory [required]
 -a|--arch ARCHITECTURE:        architecture to test [default: i386]
 -m|--merge NAMES:              retain this duplicate at the latest version in all
 -p|--purge NAMES:              remove the duplicates from 'main'
 -t|--trim NAMES:               retain the duplicates in main only
 -?|-h|--help|--version:        print this help message and exit

Options:
    --grip-name STRING:         alternative name for the grip repository
 -s|--suite SUITE:              suite to check (default: unstable)
 -n|--dry-run:                  print the reprepro commands that would be used.

=head1 Description

emgrip-dupes scans the Grip repository Packages data and configuration,
identifies the supported list of components in the requested suite.

In some cases, these duplicates are useful and only a small amount of
space is taken up by the extra listing. However, the version in one
component can easily be out of sync with the version in another.

The main emphasis is on the size of the Packages file for the 'main'
component (the one that every user needs to download). Purge mode
will remove the listing of the specified package from 'main'. Merge
mode will bring the outdated version into line with the most recent
version of the package so that all components list the most recent
version.

=cut

sub find_duplicates {
	my ($suite, $repo) = @_;
	return undef unless defined $base;
	my $src = (read_sources ($suite, $repo));
	if (not defined $src) {
		warn (_g("No sources found in '%s' repository.\n"), $repo);
		return undef;
	}
	my %list = %$src;
	undef $src;
	$src = get_archlist ($suite, $repo);
	@archlist = @$src;
	$arch = "i386" if (not defined $arch);
	next if ($arch eq 'source');
	my %package=();
	my ($parser, $fh);
	# support components other than main.
	$c = get_components ($suite, $repo);
	foreach my $cmpnt (@$c) {
		my $file = "$base/$repo/dists/$suite/$cmpnt/binary-${arch}/Packages";
		$file =~ s://:/:g;
		if (not -f $file) {
			warn (_g("Cannot find Packages file: '%s'.\n"), $file);
			next;
		}
		$fh = IO::File->new("$file") or die "$!\n";
		$parser = Parse::Debian::Packages->new( $fh );
		while (%package = $parser->next) {
			$list{$package{'Package'}}{"$cmpnt"}=$package{'Version'};
			my $src = (not defined $package{'Source'}) ?
				$package{'Package'} :
				$package{'Source'};
			$src =~ s/\(.*\)//g;
			$src =~ s/ //g;
			$list{$package{'Package'}}{'Src'}=$src
				if (not defined $list{$package{'Package'}}{'Src'});
			$sections{$package{'Package'}} = $package{'Section'};
		}
		$fh->close;
		undef $fh;
	}
	return \%list;
}

sub merge {
	my %ref=();
	my $pkgs = shift;
	my $retval;
	$cmd = "reprepro -b ${base}${grip_name}";
	use Data::Dumper;
	$src = get_archlist ($suite, $grip_name);
	@archlist = @$src;
	my @files = ();
	foreach my $dup (@$pkgs) {
		foreach my $arch (@archlist) {
			my $detail = &get_single_package ($suite, $grip_name, $dup, $arch);
			push @files, $$detail{'Filename'}
				if (defined $$detail{'Filename'});
			# support components other than main.
			$c = get_components ($suite, $grip_name);
			foreach my $cmpnt (@$c) {
				push @files, $$detail{$cmpnt}{'Filename'}
					if (exists $$detail{$cmpnt}{'Filename'});
			}
		}
		my $main = $orig{$dup}{'main'};
		my $c = get_components ($suite, $grip_name);
		foreach my $cmpnt (@$c) {
			next if ($cmpnt eq "main");
			if (defined $orig{$dup}{$cmpnt}) {
				$ref{$cmpnt} = $orig{$dup}{$cmpnt};
				printf (_g("INF: Testing whether 'main' is older than '%s'\n"), $cmpnt);
				printf (_g("INF: dpkg --compare-versions %s '>=' %s\n"), $main, $ref{$cmpnt});
				$retval = system ("dpkg --compare-versions $main '>=' $ref{$cmpnt}");
				$retval /= 256;
				if ($retval == 1) {
					printf(_g("INF: Merging %s, updating 'main' with newer ".
						"version in '%s'\n"), $dup, $cmpnt);
					foreach my $deb (@files) {
						my $e = $main;
						$e =~ s/^[0-9]://;
						next if ($deb =~ /$e/);
						print "$cmd -C main includedeb $suite ${base}${grip_name}/$deb\n"
							if (defined $dry);
						system ("$cmd -C main includedeb $suite ${base}${grip_name}/$deb")
							if (not defined $dry);
					}
					next;
				} else {
					print _g("INF: Test failed.\n");
				}
				printf (_g("INF: Testing whether 'main' is newer than '%s'\n"), $cmpnt);
				printf (_g("INF: dpkg --compare-versions %s '<=' %s\n"), $main, $ref{$cmpnt});
				$retval = system ("dpkg --compare-versions $main '<=' $ref{$cmpnt}");
				$retval /= 256;
				if ($retval == 1) {
					printf(_g("INF: Merging %s, updating '%s' with newer ".
						"version in 'main'\n"), $dup, $cmpnt);
					foreach my $deb (@files) {
						my $e = $main;
						$e =~ s/^[0-9]://;
						next if ($deb !~ /$e/);
						print "$cmd -C $cmpnt includedeb $suite ${base}${grip_name}/$deb\n"
							if (defined $dry);
						system ("$cmd -C $cmpnt includedeb $suite ${base}${grip_name}/$deb")
							if (not defined $dry);
					}
					next;
				}
				printf (_g("INF: Testing whether 'main' is newer than '%s'\n"), $cmpnt);
				printf (_g("INF: dpkg --compare-versions %s '=' %s\n"), $main, $ref{$cmpnt});
				$retval = system ("dpkg --compare-versions $main '=' $ref{$cmpnt}");
				$retval /= 256;
				if ($retval == 0) {
					printf (_g("INF: Versions are equal, %s needs to be purged.\n"), $package);
				} else {
					print _g("ERR: Cannot determine result of comparing versions.\n");
				}
			}
		}
	}
}

sub purge {
	my %ref=();
	my $pkgs = shift;
	my $retval;
	my $cmd = "reprepro -b ${base}${grip_name} -V";
	use Data::Dumper;
	$src = get_archlist ($suite, $grip_name);
	@archlist = @$src;
	foreach my $dup (@$pkgs) {
		$main = $orig{$dup}{'main'};
		$c = get_components ($suite, $grip_name);
		foreach my $cmpnt (@$c) {
			next if ($cmpnt eq "main");
			if (defined $orig{$dup}{$cmpnt}) {
				$ref{$cmpnt} = $orig{$dup}{$cmpnt};
				printf (_g("INF: Testing whether 'main' is older than or the same as '%s'\n"), $cmpnt);
				printf (_g("INF: dpkg --compare-versions %s '>=' %s\n"), $main, $ref{$cmpnt});
				$retval = system ("dpkg --compare-versions $main '>=' $ref{$cmpnt}");
				$retval /= 256;
				if ($retval == 1) {
					printf(_g("INF: Removing old version in 'main': newer ".
						"version in '%s'\n"), $cmpnt);
					foreach $arch (@archlist) {
						# don't remove source from main
						next if ($arch eq "source");
						print "$cmd -A $arch -C main remove $suite $dup\n" if (defined $dry);
						system ("$cmd -A $arch -C main remove $suite $dup")
							if (not defined $dry);
					}
					next;
				}
				if ($retval == 0) {
					printf(_g("INF: Removing duplicate version in 'main': ".
						"same version in '%s'\n"), $cmpnt);
					foreach $arch (@archlist) {
						# don't remove source from main
						# if Arch: all subsequent calls will simply be ignored.
						next if ($arch eq "source");
						print "$cmd -A $arch -C main remove $suite $dup\n" if (defined $dry);
						system ("$cmd -A $arch -C main remove $suite $dup")
							if (not defined $dry);
					}
					next;
				}
				printf (_g("INF: Testing whether 'main' is newer than '%s'\n"), $cmpnt);
				printf (_g("INF: dpkg --compare-versions %s '<=' %s\n"), $main, $ref{$cmpnt});
				$retval = system ("dpkg --compare-versions $main '=' $ref{$cmpnt}");
				$retval /= 256;
				if ($retval == 1) {
					printf (_g("ERR: Old version is in '%s', newer version in 'main'!\n"), $cmpnt);
					print (_g("This is usually an error, switching to --dry-run mode.\n"));
					print "$cmd -C $cmpnt remove $suite $dup\n";
					next;
				}
			}
		}
	}
}

sub trim {
	my %ref=();
	my $pkgs = shift;
	my $retval;
	my $cmd = "reprepro -b ${base}${grip_name} -V";
	use Data::Dumper;
	$src = get_archlist ($suite, $grip_name);
	@archlist = @$src;
	foreach my $dup (@$pkgs) {
		my $main = $orig{$dup}{'main'};
		my $c = get_components ($suite, $grip_name);
		foreach my $cmpnt (@$c) {
			next if ($cmpnt eq "main");
			if (defined $orig{$dup}{$cmpnt}) {
				$ref{$cmpnt} = $orig{$dup}{$cmpnt};
				printf (_g("INF: Testing whether 'main' is older than or the same as '%s'\n"), $cmpnt);
				printf (_g("INF: dpkg --compare-versions %s '>=' %s\n"), $main, $ref{$cmpnt});
				$retval = system ("dpkg --compare-versions $main '>=' $ref{$cmpnt}");
				$retval /= 256;
				if ($retval == 1) {
					printf(_g("INF: Removing old version in '%s': newer ".
						"version in 'main'\n"), $cmpnt);
					print "$cmd -C $cmpnt remove $suite $dup\n" if (defined $dry);
					system ("$cmd -C $cmpnt remove $suite $dup")
						if (not defined $dry);
					next;
				}
				if ($retval == 0) {
					printf(_g("INF: Removing duplicate version in 'main': ".
						"same version in '%s'\n"), $cmpnt);
					print "$cmd -C $cmpnt remove $suite $dup\n" if (defined $dry);
					system ("$cmd -C $cmpnt remove $suite $dup")
						if (not defined $dry);
					next;
				}
				printf (_g("INF: Testing whether 'main' is newer than '%s'\n"), $cmpnt);
				printf (_g("INF: dpkg --compare-versions %s '<=' %s\n"), $main, $ref{$cmpnt});
				$retval = system ("dpkg --compare-versions $main '=' $ref{$cmpnt}");
				$retval /= 256;
				if ($retval == 1) {
					printf (_g("ERR: Old version is in '%s', newer version in 'main'!\n"), $cmpnt);
					print _g("This is usually an error, switching to --dry-run mode.\n");
					print "$cmd -C $cmpnt remove $suite $dup\n";
					next;
				}
			}
		}
	}
}

sub usageversion {
	printf STDERR (_g("
%s - find packages listed in more than one component

 Syntax: %s -b PATH [OPTIONS]
         %s -b PATH -m|--merge [OPTIONS] 
         %s -b PATH -p|--purge [OPTIONS]
         %s -?|-h|--help|--version

 Commands:
 -b|--base-path PATH:           path to the top level grip directory [required]
 -a|--arch ARCHITECTURE:        architecture to test [default: i386]
 -m|--merge NAMES:              retain duplicates at the latest version in all
 -p|--purge NAMES:              remove the duplicates from 'main'
 -t|--trim NAMES:               retain the duplicates in main only
 -?|-h|--help|--version:        print this help message and exit

Options:
    --grip-name STRING:         alternative name for the grip repository
 -s|--suite SUITE:              suite to check (default: unstable)
 -n|--dry-run:                  print the reprepro commands that would be used.

"), $prog, $prog, $prog, $prog, $prog)
	or die ("$0: "._g("failed to write usage").": $!\n");
}

=head1 Limitations

Next step is to automate the "correction" of the duplicates but this does
need care. Manual corrections involve identifying the packages to retain
in main (where the duplicate in dev, doc or debug is not wanted) and pass
those to --trim.

The more complex case is to remove from main (e.g. package name suffix is
-dev or -doc or -dbg or the Section is devel, dbg, doc or libdevel).
emgrip-dupes --purge removes each binary separately because removing the
package from main in a single operation will also remove the source.
This is a particular problem if the source package also builds binary
packages that are intended for main, e.g. dbus.

=head1 Copyright and Licence

 Copyright (C) 2009  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
