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

package Spider;

use strict;
use utf8;


=head1 NAME

dl10n-spider -- crawl translator mailing lists (and BTS) for status updates

=head1 SYNOPSIS

dl10n-spider [options] lang+

=head1 DESCRIPTION

This script parses the debian-l10n-E<lt>languageE<gt> mailing list
archives. It looks for emails which title follow a specific format
indicating what the author intend to translate, or the current status of
his work on this translation.

Those informations are saved to a dl10n database which can then be used to
build a l10n coordination page or any other useless statistics.

=cut

use LWP::UserAgent;
use Debian::L10n::Db;
use Debian::L10n::BTS;
use Debian::L10n::Utils;
use MIME::Base64;
use List::Util qw(max);

use Data::Dumper;


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

my $Status_file='./data/status.$lang';

my $DEFAULT_YEAR    = 2002;			# Message on french ML introducing the syntax for the first time
my $DEFAULT_MONTH   = 3;
my $DEFAULT_MESSAGE = 0;

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


=head2 get_header(HTML)

get_header extract the email header from the html page. This header starts at
E<lt>!--X-Head-of-Message--E<gt> and stops at
E<lt>!--X-Head-of-Message-End--E<gt>. As it contains html tags, they are also
removed.

It gets a reference to an array of line (HTML) containing the html code of the
page.

It returns a reference to an array containing the email header lines.

=cut

sub get_header($) {
	my $html = shift;

	my @header;

	foreach $_ (@{$html}) {
		next unless @header or	/<!--X-Head-of-Message-->/;	# begin boundary
		last if			/<!--X-Head-of-Message-End-->/;	# end boundary
		s/<[^>]*>//g;
		s/&gt;/>/g;
		s/&lt;/</g;
		push @header, $_;
	}
	shift @header;						# remove begin boundary

	\@header;
}

=head2 get_message(LANGUAGE, YEAR, MONTH, MESSAGE)

get_message requests message to the archives of a l10n mailling.

It gets the language string (LANGUAGE), year (YEAR), month (MONTH) and message
number (MESSAGE) integers.

It return a reference to an array containing the html lines or 'undef' if an
error occured.

=cut

sub get_message($$$$) {
	my $language = shift;
	my $year     = shift;
	my $month    = shift;
	my $message  = shift;

	my @html;
	my $file = sprintf "debian-l10n-%s/%d/debian-l10n-%s-%d%02d/msg%05d.html", $language, $year, $language, $year, $month, $message;
	if (-e '/org/lists.debian.org/www') {
		return undef unless -e "/org/lists.debian.org/www/$file";
		open FH, "</org/lists.debian.org/www/$file"	or die "Cannot open $file\: $!";
		@html = <FH>;
		close FH;
		chomp @html;
	} else {
		my $answer = $Web_agent -> request(HTTP::Request -> new (GET => "http://lists.debian.org/$file"));
		# The download of the web page may fail.
		# Retry three times.
		unless ($answer -> is_success) {
			$answer = $Web_agent -> request(HTTP::Request -> new (GET => "http://lists.debian.org/$file"));
		}
		unless ($answer -> is_success) {
			$answer = $Web_agent -> request(HTTP::Request -> new (GET => "http://lists.debian.org/$file"));
		}
		unless ($answer -> is_success) {
			warn "Failed to retrieve 'http://lists.debian.org/$file'\n";
			return undef;
		}
		my $html = $answer -> content;
		@html = split(/\n/, $html);
	}

	return \@html;
}


=head2 get_indexpage

retrieves all messages numbers and subjects from a page of messages
sorted by date. It return a hash table with message number as keys and subject
as values (this is really quicker than retrieving each message).

=cut

sub get_indexpage($$$$) {
	my $language = shift;
	my $year     = shift;
	my $month    = shift;
	my $page     = shift;

	my %messages;

	my @html;
	my $file = sprintf "debian-l10n-%s/%d/debian-l10n-%s-%d%02d/mail%s.html", $language, $year, $language, $year, $month, ($page == 1 ? "list" : $page);
	if (-e '/org/lists.debian.org/www') {
		return undef unless -e "/org/lists.debian.org/www/$file";
		open FH, "</org/lists.debian.org/www/$file"	or die "Cannot open $file\: $!";
		@html = <FH>;
		close FH;
		chomp @html;
	} else {
		my $answer = $Web_agent -> request(HTTP::Request -> new (GET => "http://lists.debian.org/$file"));
		return undef unless $answer -> is_success;
		my $html = $answer -> content;
		@html = split /\n/, $html;
	}
	@html = grep  /name="\d{5}" href="msg\d{5}\.html"/, @html;

	%messages = (%messages, map {
	   	m/name="(\d{5})"/;
	   	my $n = $1;
		s/<.*?>//g;
		($n, $_)
		} @html);

	return \%messages;
}


sub spider($$$$$@) {
	my $init_year    = shift;
	my $init_month   = shift;
	my $init_message = shift;
	my $check_bts = shift;
	   $Status_file  = shift || $Status_file;
	   $_            = shift || 'all';

	my @langs;
	if (m/^all$/i) {
		@langs = keys %Debian::L10n::Utils::Language;
	} else {
		@langs = ($_, @_);
	}

	while (my $lang = shift @langs) {
		die "Spider.pm: Lang '$lang' unknown. Please update \%Language.\n"
		    unless $Debian::L10n::Utils::Language{$lang};
		print "Spider.pm $Debian::L10n::Utils::Language{$lang}\n";
		my $year;
		my $month;
		my $message;
		my $page;
		my $db = Debian::L10n::Db->new();
		my $dbName = "$Status_file";			# FIXME add $lang if not provided in command line FIXME
		   $dbName =~ s/\$lang/$lang/g;
		if (-e $dbName) {
			$db->read($dbName, 0);
			$year    = (defined($init_year)    ? $init_year    : ($db->get_header('Year')    || $DEFAULT_YEAR   ));
			$month   = (defined($init_month)   ? $init_month   : ($db->get_header('Month')   || $DEFAULT_MONTH  ));
			$message = (defined($init_message) ? $init_message : ($db->get_header('Message') || $DEFAULT_MESSAGE));
			$page    = (defined($init_message) ? 1             : ($db->get_header('Page')    || 1               ));
			print "Spider.pm Continue $Debian::L10n::Utils::Language{$lang} from message $year/$month/$message\n";
		} else {
			print "Spider.pm Creating a new DB for $Debian::L10n::Utils::Language{$lang}\n";
			$year    = $init_year;
			$month   = $init_month;
			$message = $init_message;
			$page    = 1;
			die "Cannot guess the begin year. Please use the --year options\n"       unless defined($year);
			die "Cannot guess the begin month. Please use the --month options\n"     unless defined($month);
			die "Cannot guess the begin message. Please use the --message options\n" unless defined($message);
			$message--;
		}

		my $last_ok = 1;
		$message++;

		while (1) {
			my $messages = get_indexpage($Debian::L10n::Utils::LanguageList{$lang}, $year, $month, $page);

			# if no more page, check if we need to look at next month
			unless ($messages) {
				last unless $last_ok;
				$message = 0;
				$page = 1;
				$month++;
				if ($month == 13) {
					$month = 1;
					$year++;
				}
				$last_ok = 0;
				redo;
			}
			$last_ok = 1;

			while ($message <= max(keys %$messages)) {
				my $key = sprintf("%05d", $message);
				my ($status, $type, $bug_nb, @names);
				if (defined ${$messages}{$key}) {
				  ($status, $type, $bug_nb, @names) = Debian::L10n::Utils::parse_subject(${$messages}{$key});
				  print "Spider.pm: [$lang:$year/$month/$message] ${$messages}{$key}\n";
				  next unless $status; # unparsable mail
				}

				my $html = get_message($Debian::L10n::Utils::LanguageList{$lang}, $year, $month, $message);
				next unless defined $html;

				my $header = get_header($html);

				if (not defined ${$messages}{$key}) {
				  my ($s) = grep(/Subject: / , @$header);
				  ($status, $type, $bug_nb, @names) = Debian::L10n::Utils::parse_subject($s);
				  print "Spider.pm: [$lang:$year/$month/$message] $s\n";
				  next unless $status; 	# unparsable mail
				}

				my ($t) = grep(/From: / , @$header);
				# In case there's no From header:
				$t = "UNKNOWN" unless defined $t;
				my  $translator = Debian::L10n::Utils::parse_from($t);

				my ($d) = grep(/Date: / , @$header);
				my  $date = Debian::L10n::Utils::parse_date($d);

				my  $list = sprintf("%04d-%02d-%05d", $year, $month, $message);

				my  $url = "";

				foreach my $pkg (@names) {
					my $file = $pkg;

					if (($type eq 'webwml') or ($type eq 'wml')) {
						$type = "wml";
						$pkg  =~ s|/.*||;
						if (($pkg=~/\./) && not($pkg =~ /\.wml$/)) {
							$file =~ s|.*?/||;
						} else {			# www.debian.org
							$pkg = 'www.debian.org';
						}
					} else {
						$pkg  =~ s|/.*||;
						$file =~ s|.*?/||;
					}

					if ($db->has_package($pkg)) {
						# If a cycle was already finished.
						# Clear the status of this file
						# before we add status for the
						# new cycle.
						foreach my $statusline (@{$db->status($pkg)}) {
							my ($type_from_db, $file_from_db, $date_from_db, $status_from_db, $translator_from_db, $list_from_db, $url_from_db, $bug_nb_from_db) = @{$statusline};
							if (    $type eq $type_from_db
							    and $file eq $file_from_db
							    and $status_from_db eq 'done'
							    and $status ne 'done') {
								$db->del_status($pkg, $type, $file, $statusline);
							}
						}
					}
					unless ($db->has_package($pkg)) {
						$db->package($pkg);
						$db->add_package($pkg,$pkg);
					}
					$db->add_status($pkg, $type, $file, $date, $status, $translator, $list, $url, ($bug_nb || ""));
					print "Insert $pkg: $type#$file#$date#$status#$translator#$list#$url#".($bug_nb ? "$bug_nb" : "")."\n";

				}
			} continue {
				$db->set_header('Year',    $year   );
				$db->set_header('Month',   $month  );
				$db->set_header('Message', $message);
				$db->set_header('Page',    $page   );
				$message++;
				$db->write($dbName);
			}
		} continue {
			$page++;
		}

		Debian::L10n::BTS::check_bts($db) if $check_bts;
		$db->write($dbName);
		Debian::L10n::Db::clean_db($db);
		$db->write($dbName);
	}
}

=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

=cut

1;