#!/usr/bin/perl
# build-versions-db builds the versions mldmb database
# and is released under the terms of the GNU GPL version 3, or any
# later version, at your option. See the file README and COPYING for
# more information.
# Copyright 2016 by Don Armstrong <don@donarmstrong.com>.


use warnings;
use strict;

use Getopt::Long;
use Pod::Usage;

=head1 NAME

build-versions-db -- builds source and source maintainers file

=head1 SYNOPSIS

    build-versions-db [options] versions.idx.new versions.idx.new \
           /srv/bugs.debian.org/versions/indices/ftp

 Options:
   --debug, -d debugging level (Default 0)
   --help, -h display this help
   --man, -m display manual

=head1 OPTIONS

=over

=item B<--update>

Update an existing database; the default. B<--no-update> will regenerate an
existing database from scratch.

=item B<--debug, -d>

Debug verbosity. (Default 0)

=item B<--help, -h>

Display brief usage information.

=item B<--man, -m>

Display this manual.

=back

=head1 EXAMPLES

     build-versions-db versions.idx.new versions.idx.new \
           /srv/bugs.debian.org/versions/indices/ftp \
           stable

=cut


use vars qw($DEBUG);
use Debbugs::Versions::Dpkg;
use Debbugs::Config qw(:config);
use File::Copy;
use MLDBM qw(DB_File Storable);
use Fcntl;

my %options = (debug           => 0,
               help            => 0,
               man             => 0,
	       update          => 1,
              );

GetOptions(\%options,
	   'update!',
           'debug|d+','help|h|?','man|m');

pod2usage() if $options{help};
pod2usage({verbose=>2}) if $options{man};

$DEBUG = $options{debug};

my @USAGE_ERRORS;

if (not @ARGV >= 4) {
    push @USAGE_ERRORS,
        "You must provide at least four arguments, two databases, ".
        "a top level directory and at least one suite";
}


pod2usage(join("\n",@USAGE_ERRORS)) if @USAGE_ERRORS;


my $versions = shift @ARGV;
my $versions_time = shift @ARGV;
my $versions_new = $versions."_".$$."_".time;
my $versions_time_new = $versions_time."_".$$."_".time;
my $toplevel = shift @ARGV;
my @suites = @ARGV;

$MLDBM::DumpMeth=q(portable);

my $time = time;

my %db;
my %db2;
if ($options{update}) {
    copy($versions_time,$versions_time_new);
}
tie %db, "MLDBM", $versions_new, O_CREAT|O_RDWR, 0664
    or die "tie $versions: $!";
tie %db2, "MLDBM", $versions_time_new,O_CREAT|O_RDWR, 0664
     or die "tie $versions_time failed: $!";

update_versions_suites(\%db,\%db2,\@suites);
versions_time_cleanup(\%db2) if $options{update};

move($versions_new,$versions);
move($versions_time_new,$versions_time);

sub open_compressed_file {
    my ($file) = @_;
    my $fh;
    my $mode = '<:encoding(UTF-8)';
    my @opts;
    if ($file =~ /\.gz$/) {
	$mode = '-|:encoding(UTF-8)';
	push @opts,'gzip','-dc';
    }
    if ($file =~ /\.xz$/) {
	$mode = '-|:encoding(UTF-8)';
	push @opts,'xz','-dc';
    }
    if ($file =~ /\.bz2$/) {
	$mode = '-|:encoding(UTF-8)';
	push @opts,'bzip2','-dc';
    }
    open($fh,$mode,@opts,$file);
    return $fh;
}

# Read Package, Version, and Source fields from a Packages.gz file.
sub read_packages {
    my ($db,$db2,$packages, $component,$arch,$dist) = @_;
    my $PACKAGES = open_compressed_file($packages) or
        die "Unable to open $packages for reading: $!";
    local $_;
    local $/ = '';	# paragraph mode

    print STDERR "reading packages $packages\n" if $DEBUG;
    for (<$PACKAGES>) {
	/^Package: (.+)/im or next;
	my $pkg = $1;
	/^Version: (.+)/im or next;
	my $ver = $1;
	my $extra_source_only = 0;
	if (/^Extra-Source-Only: yes/im) {
	    $extra_source_only = 1;
	}
	update_package_version($db,$db2,$dist,$arch,$pkg,$ver,$time) unless
	    $extra_source_only;
    }
    close($PACKAGES) or
	die "Error while closing ${packages}: $!";
}


sub update_package_version {
    my ($db,$db2,$d,$a,$p,$v,$t) = @_;
    # see MLDBM(3pm)/BUGS
    my $tmp = $db->{$p};
    # we allow multiple versions in an architecture now; this
    # should really only happen in the case of source, however.
    push @{$tmp->{$d}{$a}}, $v;
    $db->{$p} = $tmp;
    $tmp = $db2->{$p};
    $tmp->{$d}{$a}{$v} = $time if not exists
	$tmp->{$d}{$a}{$v};
    $db2->{$p} = $tmp;
}

sub update_versions_suites {
    my ($db,$db2,$suites) = @_;
# Iterate through all Packages and Sources files.
for my $suite (@{$suites}) {
    my $suitedir = "$toplevel/$suite";

    for my $component ('main', 'main/debian-installer',
		       'contrib', 'contrib/debian-installer',
		       'non-free', 'non-free/debian-installer',
		       'non-free-firmware', 'non-free-firmware/debian-installer',
		      ) {
	my $componentdir = "$suitedir/$component";
	if (not -d $componentdir) {
	    print STDERR "No directory $suitedir/$component\n" if $DEBUG;
	    next;
	}
	my $COMPONENT;
	opendir $COMPONENT, $componentdir or die "opendir $componentdir: $!";

	# debian-installer is really a section rather than a component
	# (ugh).
	my $viscomponent = $component;
	$viscomponent =~ s[/.*][];

	my $sources = (grep { -f $_ } glob "$componentdir/source/Sources.*")[0];
	if (not defined $sources) {
	    print STDERR "No sources matching $componentdir/source/Sources.*\n" if $DEBUG;
	} else {
	    read_packages($db,$db2,$sources, $viscomponent,'source',$suite);
	}
	for my $arch (readdir $COMPONENT) {
	    next unless $arch =~ s/^binary-//;
	    my $archdir = "$componentdir/binary-$arch";

	    my $packages = (grep { -f $_ } glob("$archdir/Packages.*"))[0];
	    if (not defined $packages) {
		print STDERR "No binary packages matching $archdir/Packages.*\n" if $DEBUG;
		next;
	    }
	    read_packages($db,$db2,$packages, $viscomponent,$arch,$suite);
	}

	closedir $COMPONENT or
	    die "Unable to closedir $componentdir: $!";
    }
}
}

sub versions_time_cleanup {
    my ($db) = @_;
    my $time = time;
    for my $package (keys %{$db}) {
	my $temp = $db->{$package};
	for my $dist (keys %{$temp}) {
	    for my $arch (keys %{$temp->{$dist}}) {
		my @versions =  (sort {$temp->{$dist}{$arch}{$a} <=>
					   $temp->{$dist}{$arch}{$b}
				       }
				 keys %{$temp->{$dist}{$arch}});
		next unless @versions > 1;
		for my $i (0 .. ($#versions-1)) {
		    last if $temp->{$dist}{$arch}{$versions[$i+1]} >
			($time - $config{remove_age}*60*60*24);
		    last if keys %{$temp->{$dist}{$arch}} <= 1;
		    delete $temp->{$dist}{$arch}{$versions[$i]};
		}
	    }
	}
	$db->{$package} = $temp;
    }
}