dl10n 3.00 / usr / share / perl5 / Debian / L10n / BTS.pm

=head1 NAME

Debian::L10n::BTS - dl10n BTS access helper

=cut

package Debian::L10n::BTS;

use strict;
use utf8;

use LWP::UserAgent;
use Date::Parse;
use Date::Format;
use Encode qw(decode_utf8);
use HTML::Entities qw(encode_entities_numeric);

use Data::Dumper;


my $VERSION = "1.0";				# External Version Number

my $Web_agent =  LWP::UserAgent -> new;
$Web_agent->env_proxy;


=head2 check_bts

check_bts searches in the BTS for open bugs, it fixes the bug submission date
if necessary, checks whether the bug is fixed or closed or not and updates the
database accordingly.

=cut

sub check_bts($@) {
	my $db = shift;
	my $dbName = shift;
	check_bts_soap($db, $dbName);
}

my $BTS = "http://bugs.debian.org";
#my $BTS = "http://bugs.donarmstrong.com";
use Data::Dumper;
use SOAP::Lite;

my $soap = SOAP::Lite->uri('Debbugs/SOAP')->proxy("$BTS/cgi-bin/soap.cgi");

sub parse_submitter($) {
	my $submitter = shift;

	$submitter = Debian::L10n::Utils::parse_from($submitter);

	$submitter = decode_base64($submitter) if $submitter =~ /^: /;
	$submitter = encode_entities_numeric(decode_utf8($submitter));
	$submitter =~ s/&lt;/</;
	$submitter =~ s/&gt;/>/;

	return $submitter;
}

my %seen;
my %opendate;
my %closedate;
my %bugsubmitter;
sub check_bts_soap($$) {
	my $db = shift;
	my $dbName = shift;

	my @bugs_to_check;

	foreach my $pkg (sort (grep { $db->has_status($_) } $db->list_packages())) {
		# Only check a bug if the last status for a file/type is BTS
		my %last_status = ();
		foreach my $statusline (@{$db->status($pkg)}) {
			my ($type, $file, $date, $status_from_db, $translator, $list, $url, $bug_nb) = @{$statusline};
			warn "$pkg\:$type\:$file does not specify the status\n"
				unless defined $status_from_db;
			$last_status{$type}{$file} = $statusline;
		}

		foreach my $t (keys %last_status) {
			foreach my $f (keys %{$last_status{$t}}) {
				my $statusline = $last_status{$t}{$f};
				my ($type, $file, $date, $status_from_db, $translator, $list, $url, $bug_nb) = @{$statusline};
				next	unless defined $status_from_db;
				next	unless $bug_nb;
				next	unless    ($status_from_db eq 'bts')
				               || ($status_from_db eq 'wontfix')
				               || ($status_from_db eq 'fix');
				push @bugs_to_check, ($pkg, $statusline);
			}
		}
	}

	check_bts_bugs_soap ($db, $dbName, @bugs_to_check)
		if (@bugs_to_check);
}

sub check_bts_bugs_soap ($$@) {
	my ($db, $dbName, @bugs_to_check) = @_;

	# Get the list of bugs
	my $i = 0;
	my %bugs;
	while ( $i < $#bugs_to_check ) {
		my ($type, $file, $date, $status_from_db, $translator, $list, $url, $bug_nb) = @{$bugs_to_check[$i+1]};
		$bugs{$bug_nb} = 1;
		$i+=2;
	}

	# Query the BTS
	my $soap_bugs = $soap->get_status([keys %bugs])->result();
	if (not defined $soap_bugs or not length $soap_bugs) {
		warn "Failed to query the BTS\n";
		return 0;
	}

	# Now we can Update the database
	my $count = 0;
	while (@bugs_to_check) {
		my $pkg = shift @bugs_to_check;
		my $statusline = shift @bugs_to_check;
		my $changed = 0; # 0: No changes
		                 # 1: Updated
		                 # 2: New status added
		my ($type, $file, $date, $status_from_db, $translator, $list, $url, $bug_nb) = @{$statusline};
		my $bugwontfix = 0;

		# Make sure the database is written from time to time
		if ($count > 10) {
			$count = 0;
			$db->write($dbName) if defined $dbName;
		}

		unless ($seen{$bug_nb}) {
			my $bugdone = 0;
			my $content;

			my $pkg_bug = $soap_bugs->{$bug_nb}->{package};
			my $src_bug = $soap_bugs->{$bug_nb}->{source};
			if (    ($pkg_bug ne $pkg)
			    and ($src_bug ne $pkg)
			    and ($pkg_bug ne "wnpp")) {
				warn "Warning: #$bug_nb filled against $pkg_bug (source: $src_bug) but $pkg is in the database\n";
			}
			$opendate{$bug_nb} = Date::Format::time2str("%Y-%m-%d %T %z", $soap_bugs->{$bug_nb}->{date}, "GMT");
			$bugsubmitter{$bug_nb} = parse_submitter($soap_bugs->{$bug_nb}->{originator});

			if (    defined $soap_bugs->{$bug_nb}->{done}
			    and length $soap_bugs->{$bug_nb}->{done}) {
				$bugdone = 1;
# TODO: differentiate fixed and done ?
			} else {
				$bugwontfix = 1 if ($soap_bugs->{$bug_nb}->{tags} =~ m/\bwontfix\b/);
			}

			if ($bugdone) {
				my $bts_url = "$BTS/cgi-bin/bugreport.cgi?bug=$bug_nb'}";
				my $answer  = $Web_agent -> request(HTTP::Request -> new (GET => $bts_url));
				return 0 unless $answer -> is_success;
				$content =  $answer -> content_ref;
				return 0 unless $$content;
				$seen{$bug_nb} = 1;

				$$content =~ /(.*?)Message #[0-9]+<\/a> received at (?:submit|maintonly)\@bugs\.debian\.org(.*)/ms;

				my $v = $$content;
				$v = $1 while ($v =~ /Message #[0-9]+<\/a> received at $bug_nb-(?:close|done)\@bugs\.debian\.org(.*)/ms);
				$v =~ /^<b>Date:<\/b> (.*)/m;
				$closedate{$bug_nb} = $1;
				$closedate{$bug_nb} =
				Debian::L10n::Utils::parse_date("Date: ".$closedate{$bug_nb} || $date);
			}
		}

		if ($closedate{$bug_nb}) {
			if ($closedate{$bug_nb} ne $date) {
				$date = $closedate{$bug_nb};
				$changed = 1 unless $changed == 2;
			}
			if ($status_from_db ne 'done') {
				print "close #$bug_nb of $pkg (at $closedate{$bug_nb})\n";
				$status_from_db = 'done';
				$changed = 2;
			}
		} else {
			if ($opendate{$bug_nb} ne $date) {
				print "fix date of #$bug_nb of $pkg from $date to $opendate{$bug_nb}.\n";
				$date = $opendate{$bug_nb};
				$changed = 1 unless $changed == 2;
			}
			if ($bugwontfix and $status_from_db ne 'wontfix') {
				print "wontfix #$bug_nb of $pkg\n";
				$status_from_db = 'wontfix';
				$changed = 2;
			}
		}
		if ($bugsubmitter{$bug_nb} ne $translator) {
			print "fix submitter of #$bug_nb of $pkg from $translator to $bugsubmitter{$bug_nb}.\n";
			$translator = $bugsubmitter{$bug_nb};
			$changed = 1 unless $changed == 2;
		}
		if ($status_from_db eq 'wontfix' and not $bugwontfix) {
			print "removing wontfix tag for #$bug_nb of $pkg\n";
			$status_from_db = 'bts';
			$changed = 2;
		}

		if ($changed == 2) {
			$db->add_status($pkg, $type, $file, $date, $status_from_db, $translator, $list, $url, $bug_nb);
		} elsif ($changed == 1) {
			$db->set_status($pkg, $type, $file, $date, $status_from_db, $translator, $list, $url, $bug_nb, $statusline);
		}
	}
}

=head1 LICENSE

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, write to the Free Software Foundation, Inc.,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

=head1 COPYRIGHT (C)

 2003,2004 Tim Dijkstra
 2004 Nicolas Bertolissio
 2004 Martin Quinson
 2008 Nicolas François

=cut

1;