#!/usr/bin/perl -w
# list-srcpkg -- lintian helper script

# Copyright (C) 1998 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., 51 Franklin St, Fifth Floor, Boston,
# MA 02110-1301, USA.

use strict;
use warnings;

use lib "$ENV{'LINTIAN_ROOT'}/lib";
use Lintian::Relation::Version qw(versions_lte);

# turn file buffering off:
$| = 1;

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

my $verbose = 0;
my $output_file = undef;

while (my $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
use lib "$ENV{'LINTIAN_ROOT'}/lib";
use Read_pkglists;
use Util;

# get variables out of environment
my $LINTIAN_ARCHIVEDIR = $ENV{'LINTIAN_ARCHIVEDIR'};
my $LINTIAN_DIST = $ENV{'LINTIAN_DIST'};
my $LINTIAN_LAB = $ENV{'LINTIAN_LAB'};
my $LINTIAN_AREA = $ENV{'LINTIAN_AREA'};

# read old list file (this command does nothing if the file does not exist)
my $ref = {};
# ignore the contents if the contents cannot be read - that is what we
# used to do!
eval { $ref = read_src_list($output_file) };
my %source_info = %$ref;

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

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

# parse Sources.gz to get list of packages
my @sources;
foreach my $area (split /\s*,\s*/,$LINTIAN_AREA) {
    my %hash;
    $hash{'dist'} = $LINTIAN_DIST;
    $hash{'area'} = $area;
    $hash{'file'} = "$LINTIAN_ARCHIVEDIR/dists/$hash{'dist'}/$hash{'area'}/" .
                    'source/Sources.gz';
    push @sources, \%hash;
}

my %packages;
my $total = 0;

foreach my $sources (@sources) {
  print "N: Parsing $sources->{'file'} ...\n" if $verbose;
  open(IN, '-|', 'zcat', $sources->{'file'})
    or fail("Cannot open input pipe from zcat $sources->{'file'}: $!");

  my $line;

  while (!eof(IN)) {
    my $pkg_dir;
    my $dsc_file;

    do {
      $line = <IN>;
      if ($line =~ m/^Directory: (.*)$/) {
        $pkg_dir = $1;
      } elsif ($line =~ m/^ [0-9a-f]{32} [0-9]+ (.+\.dsc)$/) {
        $dsc_file = $1;
      }
    } until (not defined($line) or $line =~ /^\s*$/);
    $dsc_file = "$pkg_dir/$dsc_file";

    my @stat;
    # get timestamp...
    unless (@stat = stat "$LINTIAN_ARCHIVEDIR/$dsc_file") {
      warn "E: general: cannot stat file $LINTIAN_ARCHIVEDIR/$dsc_file: $!\n";
      next;
    }
    my $timestamp = $stat[9];

    my ($status,$pkg,$data);

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

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

    if (($status eq 'new') or ($status eq 'changed')) {
      # use eval when calling get_dsc_info, since we don't want to `die' just
      # because of a single broken package
      eval { $data = get_dsc_info("$LINTIAN_ARCHIVEDIR/$dsc_file"); };
      if ($@) {
        # error!
        print STDERR "$@\n";
        print "E: general: bad-source-package $dsc_file\n";
        next;
      }
      my @f = ();
      for my $fs (split(/\n/,$data->{'files'})) {
        next if $fs =~ /^\s*$/o;
        my @t = split(/\s+/o,$fs);
        push(@f,$t[2]);
      }
      $data->{'files'} = join(',',@f);
      $data->{'standards-version'} ||= '';
      $pkg = $data->{'source'};
    }

    # Check for duplicates.  In the case of a duplicate, we take the one with
    # the latest version.
    if (exists $packages{$pkg}) {
      if (versions_lte($data->{version}, $packages{$pkg}{version})) {
        next;
      }
    }

    # Save entry for writing to output file.
    $data->{file} = $dsc_file;
    $data->{area} = $sources->{area};
    $data->{timestamp} = $timestamp;
    $data->{status} = $status;
    for (qw(version maintainer uploaders architecture standards-version
            binary files)) {
      $data->{$_} =~ tr/;\n/_ / if $data->{$_};
    }
    $packages{$pkg} = $data;

    # remove record from hash
    delete $source_info{$pkg} if $status eq 'unchanged';
    $total++;
  }
  close(IN) or fail("cannot close input pipe: $!");
}
for my $pkg (sort keys %packages) {
  print OUT join(';',
                 $pkg,
                 $packages{$pkg}{version},
                 $packages{$pkg}{maintainer},
                 $packages{$pkg}{uploaders} || '',
                 $packages{$pkg}{architecture},
                 $packages{$pkg}{area},
                 $packages{$pkg}{'standards-version'},
                 $packages{$pkg}{binary},
                 $packages{$pkg}{files},
                 $packages{$pkg}{file},
                 $packages{$pkg}{timestamp},
                ),"\n";
  printf "N: Listed %s source package %s %s\n", $packages{$pkg}{status},
      $pkg, $packages{$pkg}{version} if $verbose;
}
close(OUT) or fail("cannot close output pipe: $!");

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

exit 0;

# Local Variables:
# indent-tabs-mode: nil
# cperl-indent-level: 2
# End:
# vim: syntax=perl sw=2 sts=2 ts=2 et shiftround
