#!/usr/bin/perl
# list-binpkg -- lintian helper script

# Copyright (C) 1998 by Christian Schwarz
# 
# This program 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 2 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, you can find it on the World Wide
# Web at http://www.gnu.org/copyleft/gpl.html, or write to the Free
# Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
# MA 02111-1307, USA.

# turn file buffering off:
$| = 1;

# parse command line options
if ($#ARGV == -1) {
    print "list-binpkg [-v] <output-list-file>\n";
    print "options:\n";
    print "   -v  verbose\n";
    exit 0;
}

while ($arg = shift) {
    if ($arg =~ s,^-,,o) {
	if ($arg eq 'v') {
	    $verbose = 1;
	} else {
	    print STDERR "error: unknown command line argument: $arg\n";
	    exit 1;
	}
    } else {
	if ($output_file) {
	    print STDERR "error: too many command line arguments: $arg\n";
	    exit 1;
	}
	$output_file = $arg;
    }
}

unless ($output_file) {
    print STDERR "error: no output file specified\n";
    exit 1;
}

# import perl libraries
require "$ENV{'LINTIAN_ROOT'}/lib/read_pkglists.pl";
require "$ENV{'LINTIAN_ROOT'}/lib/util.pl";

# get variables out of environment
$LINTIAN_DIST = $ENV{'LINTIAN_DIST'};
$LINTIAN_ARCH = $ENV{'LINTIAN_ARCH'};
$LINTIAN_LAB = $ENV{'LINTIAN_LAB'};

# read old list file (this command does nothing if the file does not exist)
read_bin_list($output_file,1);

# map filenames to package names
for $pkg (keys %binary_info) {
    $pkgfile{$binary_info{$pkg}->{'file'}} = $pkg;
}

# open output file
open(OUT,">$output_file")
    or fail("cannot open list file $output_file for writing: $!");
print OUT "$BINLIST_FORMAT\n";

# run find to get list of packages
print "N: Searching for .deb's in directory $LINTIAN_DIST ...\n" if $verbose;
open(IN,"cd $LINTIAN_DIST; find . -name \"*.deb\" \\( -type f -o -type l \\) |")
    or fail("cannot open input pipe: $!");

while (<IN>) {
    chop;

    my $deb_file = $_;
    my ($arch, $pkgdata);

    undef $pkgdata;

    # Get architecture.  There are three sources for this information:
    if (m,/binary-([^/]+)/,) {
	# It's in the directory name
	$arch = $1;
    } elsif (m,/[^/]+_[^/]+_([^/]+).deb$/,) {
	# It's in the filename
	$arch = $1;
    } else {
	# Look in the deb file
	$pkgdata = &safe_get_deb_info($deb_file);
	next if not defined $pkgdata;
	$arch = $pkgdata->{'architecture'};
    }
	
    # correct architecture?
    next unless $arch eq $LINTIAN_ARCH;

    # get timestamp...
    unless (@stat = stat "$LINTIAN_DIST/$deb_file") {
	print "E: general: cannot-stat $deb_file\n";
	next;
    }
    my $timestamp = $stat[9];
    my ($status, $pkg, $data);

    # was package already included in last list?
    if (exists $pkgfile{$deb_file}) {
	# yes!
	$pkg = $pkgfile{$deb_file};
	$data = $binary_info{$pkg};

	# file changed since last run?
	if ($timestamp == $data->{'timestamp'}) {
	    # no.
	    $status = 'unchanged';
	} else {
	    $status = 'changed';
	    delete $binary_info{$pkg};
	}
    } else {
	# new package, get info
	$status = 'new';
    }

    if (($status eq 'new') or ($status eq 'changed')) {
	if (defined $pkgdata) {
	    # avoid collecting the info twice
	    $data = $pkgdata;
	} else {
	    $data = &safe_get_deb_info($deb_file);
	}
	next if not defined $data;
	$pkg = $data->{'package'};
    }

    # check for duplicates
    if (exists $packages{$pkg}) {
	print "E: general: duplicate-binary-package $pkg\n";
	next;
    }

    # write entry to output file
    print OUT join(';',
		   $pkg,
		   $data->{'version'},
		   $data->{'source'},
		   $deb_file,
		   $timestamp,
		   ),"\n";
    printf "N: Listed %s binary package %s %s\n",$status,$pkg,$data->{'version'} if $verbose;

    # remove record from hash
    delete $binary_info{$pkg} if $status eq 'unchanged';
    $packages{$pkg} = 1;
    $total++;
}
close(IN) or fail("cannot close input pipe: $!");
close(OUT) or fail("cannot close output pipe: $!");

if ($verbose) {
    # all packages that are still included in %binary_info have disappeared from the archive...
    for $pkg (sort keys %binary_info) {
	print "N: Removed binary package $pkg from list\n";
    }
    printf "N: Listed %d binary packages\n",$total;
}

exit 0;

sub safe_get_deb_info {
    # use eval when calling get_deb_info, since we don't want to `die' just
    # because of a single broken package
    eval { $data = get_deb_info("$LINTIAN_DIST/$_[0]"); };
    if ($@) {
	# error!
	print STDERR "$@\n";
	print "E: general: bad-binary-package $_[0]\n";
	return undef;
    }
    $data->{'source'} or ($data->{'source'} = $data->{'package'});
    return $data;
}
