#! /usr/bin/perl -w

# Original shell script version:
# Copyright 1998,1999 Yann Dirson <dirson@debian.org>
# Perl version:
# Copyright 1999 by Julian Gilbey <jdg@debian.org>
# 
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License, version 2 ONLY,
# as published by the Free Software Foundation.
# 
# 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.

use 5.003;
use strict;
use Cwd;
use File::Basename;
use lib '@pkgdatadir@';
use checkgettext;

# Predeclare functions
sub fatal(@);

setlocale(LC_MESSAGES(), "");
textdomain("devscripts");

(my $progname = $0) =~ s|.*/||;
my $ignore_dirs = 1;
my (@from, @to, $from, $to, @filelist1, @filelist2);
my ($file1, $file2, @gains, @losses);

my $usage = sprintf gettext(<<'EOF'), $progname, $progname;
Usage: %s [-d|--dirs] [--move|-m old-loc new-loc] ... deb1 deb2
   or: %s [-d|--dirs] [--move|-m old-loc new-loc] ... changes1 changes2
EOF

my $version = sprintf gettext(<<'EOF'), $progname, '@VERSION@';
This is %s, from the Debian devscripts package, version %s
This code is copyright 1999 by Julian Gilbey <jdg@debian.org>, based on 
original code which is copyright 1998,1999 Yann Dirson <dirson@debian.org>
This program comes with ABSOLUTELY NO WARRANTY.
You are free to redistribute this code under the terms of the
GNU General Public License, version 2 ONLY.
EOF

##
## handle command-line options
##
if ($ARGV[0] eq '--help') { print $usage; exit 0; }
if ($ARGV[0] eq '--version') { print $version; exit 0; }

@from = @to = ();
while (@ARGV > 2) {
    if ($ARGV[0] =~ /^(--move|-m)$/) {
	fatal $usage unless @ARGV >= 5;
	shift @ARGV;
	push @from, shift;
	push @to,   shift;
    }
    elsif ($ARGV[0] =~ /^(--dirs|-d)$/) { $ignore_dirs = 0; shift; }
    else { fatal $usage }
}

# Ensure from and to lists all begin with a slash
# This is because the format of the tar archive has changed between
# slink and potato, and we must recognise both forms:
# slink: usr/lib/filename
# potato: ./usr/lib/filename
map { $_ =~ s,^\./,/,; $_ =~ s,^([^/]),/$1,; } @from;
map { $_ =~ s,^\./,/,; $_ =~ s,^([^/]),/$1,; } @to;

##
## we need 2 deb files or changes files to compare
##
fatal $usage unless @ARGV == 2;

foreach my $i (0,1) {
    fatal gettext("Can't read file: "), $ARGV[$i] unless -r $ARGV[$i];
}

# Are they debs or changes files?
my $type;
if ($ARGV[0] =~ /\.deb$/) { $type = 'deb'; }
elsif ($ARGV[0] =~ /\.changes$/) { $type = 'changes'; }
elsif (`file $ARGV[0]` =~ /Debian/) { $type = 'deb'; }
else {
    fatal gettext("Could not recognise files; the names should end .deb or .changes");
}

my (@deb1, @deb2);
my ($D1, $D2) = ('','');

if ($type eq 'deb') {
    @deb1 = ($ARGV[0]);
    @deb2 = ($ARGV[1]);
    foreach my $D (\$D1,\$D2) {
	my $deb = shift;
	$$D = `dpkg-deb -c $deb`;
	$? == 0 or fatal gettext("Couldn't fork ") . "dpkg-deb -c $deb: $!";
    }
}
else {
    # Have to parse .changes files
    my $pwd = cwd;
    foreach my $D (\$D1,\$D2) {
	my $changes = shift;
	open CHANGES, $changes
	    or fatal sprintf(gettext("Couldn't open %s: "),$changes), "$!";
	my (@debs) = ();
	my $infiles = 0;
	while (<CHANGES>) {
	    last if $infiles and /^[^ ]/;
	    /^Files:/ and $infiles=1, next;
	    next unless $infiles;
	    / (\S*.deb)$/ and push @debs, $1;
	}
	close CHANGES
	    or fatal sprintf(gettext("Problem reading %s: "),$changes), "$!";

	chdir dirname($changes)
	    or fatal gettext("Couldn't chdir "), dirname($changes), ": $!";
	foreach my $deb (@debs) {
	    $$D .= `dpkg-deb -c $deb`;
	    $? == 0
		or fatal gettext("Couldn't fork ") . "dpkg-deb -c $deb: $!";
	}
	# Go back again
	chdir $pwd or fatal gettext("Couldn't chdir "), $pwd, ": $!";
    }
}

##
## Compare
##

# Format of output:
# permissions owner/group size date time name ['->' link destination]
# And remember the slink -> potato stuff
$D1 =~ s/^(\S+\s+){5}(\S+)( -> \S+)?\s*$/$2/mg;
$D2 =~ s/^(\S+\s+){5}(\S+)( -> \S+)?\s*$/$2/mg;
$D1 =~ s,^\./,/,mg;
$D2 =~ s,^\./,/,mg;
$D1 =~ s,^([^/]),/$1,mg;
$D2 =~ s,^([^/]),/$1,mg;
@filelist1 = split /\n/, $D1;
@filelist2 = split /\n/, $D2;

# Are we keeping directory names in our filelists?
if ($ignore_dirs) {
    @filelist1 = grep ! m|/$|, @filelist1;
    @filelist2 = grep ! m|/$|, @filelist2;
}

# Do the "move" substitutions in the order received
while (@from) {
    $from = shift @from;
    $to   = shift @to;
    map { $_ =~ s/^$from/$to/ } @filelist1;
}

my %files;
grep $files{$_}--, @filelist1;
grep $files{$_}++, @filelist2;

@losses = sort grep $files{$_} < 0, keys %files;
@gains = sort grep $files{$_} > 0, keys %files;

if (@losses == 0 && @gains == 0) {
    print gettext("File lists identical (after any substitutions)\n");
    exit 0;
}

if (@gains) {
    my $msg = sprintf gettext("Files in second .%s but not in first"),
		    $type eq 'deb' ? 'deb' : 'changes';
    print $msg, "\n", '-' x length $msg, "\n";
    print join("\n",@gains), "\n";
}

if (@losses) {
    print "\n" if @gains;
    my $msg = sprintf gettext("Files in first .%s but not in second!"),
		    $type eq 'deb' ? 'deb' : 'changes';
    print $msg, "\n", '-' x length $msg, "\n";
    print join("\n",@losses), "\n";
}

###### Subroutines

sub fatal(@) {
    my ($pack,$file,$line);
    ($pack,$file,$line) = caller();
    (my $msg = sprintf(gettext("%s: fatal error at line %d:\n"),
		       $progname, $line) . "@_\n") =~ tr/\0//d;
    $msg =~ s/\n\n$/\n/;
    die $msg;
}