#! /usr/bin/perl -w
# Extract version information from an existing non-versioned database by
# guesswork, based on Version: pseudo-headers and closing mails that look
# like Debian changelogs. The latter in particular is somewhat heuristic.

# <@aj> Hackin' on the BTS, Feelin' like it'll take forever; Oh you better
#       hold it's hand, when it dies on names so clever. These are the best
#       bugs of our life. It's up to archive-slash-69, man we were killin'
#       time, we were young and resltess, we needed to unwind. I guess
#       nothin' can last forever - forever, no...

my $config_path = '/etc/debbugs';
my $lib_path = '/usr/lib/debbugs';

require "$config_path/config";
require "$lib_path/errorlib";

use Debbugs::Log;
use Debbugs::MIME;

if (@ARGV != 1) {
    print <<EOF;
Usage: $0 db-type

EOF
    exit 0;
}

sub getbuginfo ($)
{
    my $log = shift;

    open LOG, "< $log" or die "Can't open $log: $!";
    my @records = read_log_records(*LOG);
    close LOG;

    my (@found_versions, @fixed_versions);
    my (%found_versions, %fixed_versions);

    for my $record (@records) {
	if ($record->{type} eq 'html') {
	    # Reassigns zap the found and fixed version list. Reopens will
	    # zap the fixed list too in the full deployment, but doing that
	    # here causes problems in case of accidental reopens and
	    # recloses.
	    if ($record->{text} =~ /assigned/) {
		@found_versions = ();
		%found_versions = ();
		@fixed_versions = ();
		%fixed_versions = ();
	    }
	    next;
	}

	next unless $record->{type} eq 'autocheck' or
		    $record->{type} eq 'incoming-recv';
	my $decoded = Debbugs::MIME::parse($record->{text});
	next unless defined $decoded;

	# Was it sent to -done or -close?
	my $closing = 0;
	my $firstreceived = $decoded->{header}[0];
	if ($firstreceived =~ /\(at [^)]*-(?:done|close)\)/) {
	    $closing = 1;
	}

	# Get Version: pseudo-headers.
	my $i;
	my ($source, $sourcever, $ver);
	for ($i = 0; $i < @{$decoded->{body}}; ++$i) {
	    last if $decoded->{body}[$i] !~ /^(\S+):\s*(.*)/;
	    my ($fn, $fv) = (lc $1, $2);
	    if ($fn eq 'source') {
		$source = $fv;
	    } elsif ($fn eq 'source-version' and
		     $fv =~ /^(\d[^,\s]*(?:[,\s]+|$))+/) {
		$sourcever = $fv;
	    } elsif ($fn eq 'version' and $fv =~ /^(\d[^,\s]*(?:[,\s]+|$))+/) {
		# Deal with reportbug brain-damage.
		next if $fv =~ /^unavailable/i;
		$fv =~ s/;.*//;
		$fv =~ s/ *\(.*\)//;
		# Strip off other random junk at the end of a version.
		$fv =~ s/ +[A-Za-z].*//;
		$ver = $fv;
	    }
	}

	my @parsedvers;
	if (defined $ver) {
	    push @parsedvers, split /[,\s]+/, $ver;
	} elsif (defined $source and defined $sourcever) {
	    push @parsedvers, map "$source/$_", split /[,\s]+/, $sourcever;
	}

	if ($closing) {
	    for my $v (@parsedvers) {
		push @fixed_versions, $v
		    unless exists $fixed_versions{$v};
		$fixed_versions{$v} = 1;
		@found_versions = grep { $_ ne $v } @found_versions;
		delete $found_versions{$v};
	    }
	} else {
	    for my $v (@parsedvers) {
		push @found_versions, $v
		    unless exists $found_versions{$v};
		$found_versions{$v} = 1;
		@fixed_versions = grep { $_ ne $v } @fixed_versions;
		delete $fixed_versions{$v};
	    }
	}

	if ($closing) {
	    # Look for Debian changelogs.
	    for (; $i < @{$decoded->{body}}; ++$i) {
		if ($decoded->{body}[$i] =~
			/(\w[-+0-9a-z.]+) \(([^\(\) \t]+)\) \S+; urgency=\S+/i) {
		    my ($p, $v) = ($1, $2);
		    push @fixed_versions, "$p/$v"
			unless exists $fixed_versions{"$p/$v"};
		    $fixed_versions{"$p/$v"} = 1;
		    @found_versions = grep { $_ ne "$p/$v" } @found_versions;
		    delete $found_versions{"$p/$v"};
		    last;
		}
	    }
	}
    }

    return (\@found_versions, \@fixed_versions);
}

sub mergeinto ($$)
{
    my ($target, $source) = @_;
    my %seen = map { $_ => 1 } @$target;
    for my $v (@$source) {
	next if exists $seen{$v};
	push @$target, $v;
	$seen{$v} = 1;
    }
}

chdir $gSpoolDir or die "Can't chdir $gSpoolDir: $!";

my $db = $ARGV[0];
opendir DB, $db or die "Can't opendir $db: $!";

while (defined(my $dir = readdir DB)) {
    next if $dir =~ /^\.\.?$/ or not -d "$db/$dir";
    opendir HASH, "$db/$dir" or die "Can't opendir $db/$dir: $!";

    while (defined(my $file = readdir HASH)) {
	next unless $file =~ /\.log$/;
	next if -z "$db/$dir/$file";
	(my $bug = $file) =~ s/\..*//;

	$bug =~ /(..)$/;
	my $bughash = $1;

	print "Processing $bug ...\n" if $ENV{DEBBUGS_VERBOSE};

	my ($locks, $status) = lockreadbugmerge($bug, $db);
	unless (defined $status) {
	    unlockreadbugmerge($locks);
	    next;
	}

	if (@{$status->{found_versions}} or @{$status->{fixed_versions}}) {
	    unlockreadbugmerge($locks);
	    next;
	}

	my @merges = ();
	# Only process the lowest of each set of merged bugs.
	if (length $status->{mergedwith}) {
	    @merges = sort { $a <=> $b } split ' ', $status->{mergedwith};
	    if ($merges[0] < $bug) {
		unlockreadbugmerge($locks);
		next;
	    }
	}

	my ($found_versions, $fixed_versions) = getbuginfo("$db/$dir/$file");

	if (length $status->{mergedwith}) {
	    for my $merge (@merges) {
		$merge =~ /(..)$/;
		my $mergehash = $1;
		my ($mfound, $mfixed) =
		    getbuginfo("$db/$mergehash/$merge.log");
		mergeinto($found_versions, $mfound);
		mergeinto($fixed_versions, $mfixed);
	    }
	}

	@$fixed_versions = () unless length $status->{done};

	for my $out ($bug, @merges) {
	    if ($out != $bug) {
		filelock("lock/$out");
	    }
	    my $outstatus = readbug($out, $db);
	    $outstatus->{found_versions} = [@$found_versions];
	    $outstatus->{fixed_versions} = [@$fixed_versions];
	    writebug($out, $outstatus, $db, 2, 'disable bughook');
	    if ($out != $bug) {
		unfilelock();
	    }
	}

	unlockreadbugmerge($locks);
    }

    closedir HASH;
}

closedir DB;