#!/usr/bin/perl -w
# This is free software.
# You may distribute it under the terms of the GNU
# Lesser GPL, any version.

# Copyright 2001 by Thomas Smith <chihuahua@tmbg.org>
# $Id: yaclc,v 1.6 2001/06/24 01:08:24 tgs Exp $

$| = 1;
use strict;
use Pod::Usage;
use Getopt::Std;
use LWP::Simple;
use URI;
use Net::LDAP;
my (%opt, %index, $ldap, $server, $port, $base);

getopts("i:dhvnelp", \%opt);

=pod

=head1 NAME

yaclc - check the bug closings in a Debian changelog

=head1 SYNOPSIS

yaclc [B<-i> I</path/to/index.db>] [B<-dhvnelp>] I<changes-file>

=cut

sub vprint {
	print @_ if ($opt{'v'} or $opt{'d'});
}
sub dprint {
	print @_ if $opt{'d'};
}

# Some LDAP settings found in Ben Collins's getbugs.pl
$server = "bugs.debian.org";
$port   = "35567";
$base   = "ou=Bugs,o=Debian Project,c=US";

if ($opt{'l'}) {
	vprint "Connecting to LDAP server...";
	$ldap = Net::LDAP->new($server, port => $port) or die "$@";
	$ldap->bind;
	vprint "done.\n";
}

if ($opt{'h'}) {
	pod2usage('-verbose' => 1, '-exitval' => 1, '-msg' => "$0\n");
}

if ($opt{'i'}) {
	local *INDEXDB;
	open(INDEXDB, "<" . $opt{'i'}) or die "$! in index making";
	vprint "Reading $opt{'i'} for index...";
	while (<INDEXDB>) {
		m/^(\S+) (\d+)/ or next;
		$index{$2} = $1;
	}
	close(INDEXDB) or warn "$! in index making";
	vprint "done.\n";
}

dprint("done parsing options.\n");

sub findpkg {
	my $bugid = shift;
	$bugid =~ s/\D//g;
	my $pkg;
	dprint("Looking up bug id $bugid with..index?  ");
	$pkg = $index{$bugid};
	if ( ( ! defined($pkg) ) and $opt{'l'} ) {
		dprint("no.  LDAP?  ");
		my $results = $ldap->search(
			base => $base,
			filter => "(bugid=$bugid)",
			attrs => [ 'package' ] );
		if ($results->is_error) {
			vprint "Error in LDAP: ", $results->error, "\n";
		} else {
			my ($entry) = $results->entries;
			my ($package) = $entry->get_value('package');
			$index{$bugid} = $package;
			$pkg = $package;
		}
	} 
	if ( ( ! defined($pkg) ) and ( ! $opt{'n'} ) ) {
		dprint("no.  HTTP?  ");
		my $buguri =
		 URI->new("http://bugs.debian.org/cgi-bin/bugreport.cgi?bug=$bugid");
		my $bughtml = get($buguri);
		if (!defined($bughtml)) { # error in fetching, or server error
			dprint("no.\n");
			vprint "HTTP query failed.\n";
		} elsif ($bughtml =~ m/^<HTML><HEAD><TITLE>Error/) { # error in bts
			if ($opt{'v'}) {
				$bughtml =~ s/^<.*\n//g;
				vprint "Error in bts.\n", $bughtml;
			}
			$pkg = "";
		} else {
			$bughtml =~ m/^.*?Package: <A.*?>(.*?)<\/A>/is;
			$index{$bugid} = $1;
			$pkg = $1;
		}
	}
	if (defined($pkg)) {
		dprint("yes.  Got $pkg.\n");
	}
	return $pkg;
}

my (%pkg, $changes);
while (<>) {
	$changes .= $_;
}

if (! defined($changes)) {
	pod2usage("$0: No changelog supplied on command line or STDIN.");
}

while ($changes =~ m/^(?:Source|Binary)\s*:\s*(.*)/mg) {
	foreach (split(/\s+/, $1)) {
		$pkg{$_} = 1;
	}
}

while ($changes =~ m/^([a-zA-Z0-9\-]+)\s+\(/mg) {
	foreach (split(/\s+/, $1)) {
		$pkg{$_} = 1;
	}
}

if (! (keys %pkg)) {
	warn "Couldn't find a package in the changelog.\n";
}

(print join(" ", keys %pkg), "\n") if ($opt{'p'} || $opt{'v'});

$pkg{"wnpp"} = 1;

my (@bugid);
while ($changes =~ m/closes:\s*(?:bug)?\#\s*(\d+(?:,\s*(?:bug)?\#\s*\d+)*)/ig) {
		# regex is stolen from Developer's Reference, sec. 10.4,
		# current as of 14 Feb 2001.  two parentheses were inserted.
		# find them :-)
	my $buglist = $1;
	push(@bugid, split(/\D+/, $buglist));
}

if (! @bugid) {
	exit 0; # No bugs to go wrong in the first place.
}

my $gotbad;
foreach (@bugid) {
	my $bugpkg = findpkg($_);
	if (!defined($bugpkg)) {
		print "$_ [unknown-package] 1\n";
	} elsif ($bugpkg eq "") {
		print "$_ [unknown-package] 0\n";
		$gotbad++;
		# BTS Error is probably Bug Doesn't Exist.
	} else {
		if (exists($pkg{$bugpkg})) {
			print "$_ $bugpkg 1\n" unless ($opt{'e'});
		} else {
			print "$_ $bugpkg 0\n";
			$gotbad++;
		}
	}
}

if ($opt{'l'}) {
	$ldap->unbind and vprint "Disconnected from LDAP server.\n";
}

if ($gotbad) {
	exit 1;
} else {
	exit 0;
}

__END__

=head1 ARGUMENTS

=over 4

=item -i I<file>

Use I<file> as an index, greatly reducing load on the BTS, and greatly
increasing the speed of processing.  B<yaclc> tries using this file before it
tries any other method of getting info about the bug.  If you are on an
official Debian machine (something.debian.org), a useful argument might be '-i
/org/bugs.debian.org/spool/index.archive' or .../index.db.

=item -d

Print debugging output.  Implies -v.

=item -h

Print a usage message.

=item -v

Be verbose.

=item -n

No HTTP queries.  To disable LDAP queries simply don't specify the -l option.
Useful if you are not connected to the 'net but do have a local index.db file.

=item -e

Only print output on errors (when no bug by that id can be found, or when the
bug does not belong to the same package as the changelog.)

=item -l

Use LDAP to query the BTS before trying HTTP.

=item -p

Before the list of bugs, print a space-separated list of binary and source
packages that I<changes-file> describes.  Note that bugs that belong to the
pseudo-package B<wnpp> are treated as belonging to the correct package, but
"wnpp" is not printed here.

=item I<changes-file>

A .changes file, or a changelog in Debian format.  A .changes file works better
for multi-binary packages.  To read from STDIN, this option may be omitted or
be `-'.

=back

=head1 OUTPUT

Outputs lines of the following form:

I<bug-number> I<package> I<bit>

where I<bug-number> is a bug number, as used in the BTS, I<package> is the
package to which the bug belongs, or `[unknown-package]' if the bug does not
have a package.  I<bit> is 1 if I<package> is one of the packages which the
changes file describes or is wnpp, or 0 otherwise.  If B<yaclc> cannot look up
the bug because it cannot access a server, I<bit> will be set to 1 because it
should only be 0 if the bug definitely belongs to a different package.  If,
however, there is a Bug Tracking System Error, I<bit> will be 0 because the
Error is usually that the bug doesn't exist.  The Author thinks that this is
the Right Thing, but is probably persuadable if you care enough to talk to him.

To parse this output, you might use something like this:

    @lines = <YACLC>;
    foreach (@lines) {
        m/^(\d+) (\S+) (0|1)$/;
        my ($bugid, $package, $is_proper) = ($1, $2, $3);
	# do processing here...
    }

=head1 EXIT CODE

B<yaclc> returns 1 if any bugs were found that belong to the wrong package or
don't seem to exist, and 0 otherwise.  This is to facilitate use in scripts,
something like this:

    yaclc -e ../foobar.changes || echo "Look at your changelog once more!"

which will print all the bad bugs, and "Look at your changelog..." if there are
any bad ones.

=head1 BUGS

Bugs should be reported using the Debian bug-tracking system, available
at B<http://bugs.debian.org/>.

=head1 SEE ALSO

L<dpkg-parsechangelog>

=head1 AUTHOR AND COPYRIGHT

This program is Copyright 2001 by Thomas Smith <chihuahua@tmbg.org>.  It is
free software.  You may distribute it under the terms of the GNU
Lesser GPL, any version.

