#!/usr/bin/perl -w

# podebconf-report-po, Send outdated debconf PO files to the last translator
# Copyright (C) 2004, 2005 Fabio Tranchitella <kobold@kobold.it>
#                          Denis Barbier <barbier@debian.org>
#
# 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 Library 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.
#

## Release information
my $PROGRAM = "podebconf-report-po";
my $VERSION = "0.09";

## Loaded modules, require libmail-sendmail-perl
use strict;
eval q{use Mail::Sendmail;};
die "$PROGRAM: This program requires the libmail-sendmail-perl package.\n".
    "$PROGRAM: Aborting!\n" if $@;
my $no_zlib = 0;
eval q{use Compress::Zlib;};
if ($@) {
	$no_zlib = 1;
	eval q{ sub Compress::Zlib::memGzip { return shift; } };
}
use MIME::Base64;
use MIME::QuotedPrint;
use Getopt::Long;
use POSIX;

## Global variables
my $HELP_ARG = 0;
my $VERSION_ARG = 0;
my $VERBOSE_ARG = 0;
my $SUBMIT_ARG = 0;
my $FORCE_ARG = 0;
my $LANGUAGETEAM_ARG = 0;
my $SMTP_ARG = "";
my $TEMPLATE_ARG = "";
my $DEFAULT_ARG = 0;
my $PACKAGE_ARG = "";
my $FROM_ARG = (exists($ENV{'DEBEMAIL'}) ? $ENV{'DEBEMAIL'} : "");
my $BTS_ARG = "";
my $DEADLINE_ARG = "";
my $PODIR_ARG = "";
my $GZIP_ARG = 0;

my @TOPDIRS = qw{../.. .. .};

my $PODIR = '';

my $EDITOR = '/usr/bin/sensible-editor';

## Default templates
my $comments = "# Lines beginning with a number sign are comments, they are removed when
# sending mails.  If a line is composed of a # followed by a 'Name: Value'
# pair, it is interpreted as a mail header field and is passed to your mail
# transport agent.  You can edit/add/remove those header fields.";

my $SUBJECT_TRANSLATOR = "Please update debconf PO translation for the package <package_and_version>";
my $BODY_TRANSLATOR = $comments. "
# 
# From: <from>
# Subject: <subject>
# Reply-To: <reply-to>
#
# This mail will be sent to the following people:
<filelist>

Hi,

you are noted as the last translator of the debconf translation for
<package>. The English template has been changed, and now some messages
are marked \"fuzzy\" in your translation or are missing.
I would be grateful if you could take the time and update it.
<reply>
<deadline>

Thanks,
";

my $SUBJECT_SUBMIT = "debconf PO translations for the package <package> are outdated";
my $BODY_SUBMIT = $comments. "
# 
# From: <from>
# Subject: <subject>

Package: <package>
Version: N/A
Severity: wishlist
Tags: l10n

The following debconf translations are outdated:
  <filelist>

Translators, please send your translations to this bugreport.
<deadline>

Thanks,
";

my $SUBJECT = '';
my $BODY = '';
#  Warnings may be deleted from screen when entering editor,
#  so display them when it is closed.
my $warn = '';

## Handle options
GetOptions
(
 "help"            => \$HELP_ARG,
 "version"         => \$VERSION_ARG,
 "v|verbose"       => \$VERBOSE_ARG,
 "f|force"         => \$FORCE_ARG,
 "podir=s"         => \$PODIR_ARG,
 "smtp=s"          => \$SMTP_ARG,
 "template=s"      => \$TEMPLATE_ARG,
 "default"         => \$DEFAULT_ARG,
 "gzip"            => \$GZIP_ARG,
 "languageteam"    => \$LANGUAGETEAM_ARG,
 "package=s"       => \$PACKAGE_ARG,
 "deadline=s"      => \$DEADLINE_ARG,
 "from=s"          => \$FROM_ARG,
 "bts=s"           => \$BTS_ARG,
 "submit"          => \$SUBMIT_ARG
 ) or &Help_InvalidOption;

&Help_PrintVersion if $VERSION_ARG;
&Help_PrintHelp    if $HELP_ARG;

## Try to find default editor
$EDITOR = $ENV{'EDITOR'} if exists($ENV{'EDITOR'});
$EDITOR = $ENV{'VISUAL'} if exists($ENV{'VISUAL'});

## Try to locate the PO directory
if ($PODIR_ARG eq "") {
	foreach my $d (@TOPDIRS) {
		$PODIR = "$d/debian/po" if (-d "$d/debian/po");
	}
} else {
	$PODIR = $PODIR_ARG;
}
die "Directory po not found, exiting!\n" if $PODIR eq "";
die "Wrong argument: $PODIR is not a directory!\n" unless -d $PODIR;

if ($no_zlib && $GZIP_ARG) {
	$warn .= 
	  "Warning: This program requires the libcompress-zlib-perl package in order\n".
	  "         to support the --gzip flag, but it is not installed.\n".
	  "         PO files will not be compressed!\n\n";
	$GZIP_ARG = 0;
}

## Try to find the maintainer e-mail address and the package name

#  Package version
my $PKG_VERSION = "N/A";
#  Expanded into "<package> <version>" if version is found, <package> otherwise
my $PACKAGE_AND_VERSION = "";
if ($PACKAGE_ARG =~ s/_(.*)//) {
	$PKG_VERSION = $1;
}

if ($PACKAGE_ARG eq "" or $FROM_ARG eq "") {
	my $CONTROL = '';
	foreach my $d (@TOPDIRS) {
		$CONTROL = "$d/debian/control" if (-f "$d/debian/control");
	}
	if ($CONTROL eq '') {
		foreach my $d (@TOPDIRS) {
			$CONTROL = "$d/debian/control.in" if (-f "$d/debian/control.in");
		}
	}

	if (-f $CONTROL) {
		##  Only read the first stanza
		local $/ = "\n\n";
		open (CNTRL, "< $CONTROL")
			or die "Unable to read $CONTROL: $!\n";
		my $text = <CNTRL>;
		close (CNTRL)
			or die "Unable to close $CONTROL: $!\n";
		if ($PACKAGE_ARG eq "" && $text =~ m/^Source: (.*)/m) {
			$PACKAGE_ARG = $1;
		}

		if ($FROM_ARG eq "" && $text =~ m/^Maintainer: (.*)/m) {
			$FROM_ARG = $1;
		}
	}
}
if ($PKG_VERSION eq "N/A") {
	my $CHANGELOG = '';
	foreach my $d (@TOPDIRS) {
		$CHANGELOG = "$d/debian/changelog" if (-f "$d/debian/changelog");
	}
	if (-f $CHANGELOG) {
		#  Version information is not vital, do not abort
		#  if it cannot be retrieved.
		if (open (CHG, "< $CHANGELOG")) {
			while (<CHG>) {
				if (m/^$PACKAGE_ARG\s+\((.*)\)\s/) {
					$PKG_VERSION = $1;
				}
				last if m/^ --/;
			}
		}
		close (CHG);
	}
}
$PACKAGE_AND_VERSION = $PACKAGE_ARG .
	($PKG_VERSION ne 'N/A' ? " ".$PKG_VERSION : "");
Verbose("Package: $PACKAGE_ARG");
Verbose("Version: $PKG_VERSION");
Verbose("Maintainer: $FROM_ARG");

if ($DEADLINE_ARG ne "") {
	$DEADLINE_ARG = "\nThe deadline for receiving the updated translation is $DEADLINE_ARG.";
}

my $REPLY = '';
if ($BTS_ARG =~ m/^\d+$/) {
	$BTS_ARG .= "\@bugs.debian.org";
	$REPLY = "Please respect the Reply-To: field and send your updated translation to\n$BTS_ARG.";
} else {
	$REPLY = "Please send the updated file to me, or submit it as a wishlist bug\nagainst <package>.";
}

if ($SUBMIT_ARG) {
	$BODY = $BODY_SUBMIT;
	$SUBJECT = $SUBJECT_SUBMIT;
} else {
	$BODY = $BODY_TRANSLATOR;
	$SUBJECT = $SUBJECT_TRANSLATOR;
}

## Apply the values to the subject and to the body of the message

$SUBJECT =~ s/<package>/$PACKAGE_ARG/g;
$SUBJECT =~ s/<version>/$PKG_VERSION/g;
$SUBJECT =~ s/<package_and_version>/$PACKAGE_AND_VERSION/g;
$BODY =~ s/<reply>/$REPLY/g;
$BODY =~ s/<reply-to>/$BTS_ARG/g;
$BODY =~ s/\n# Reply-To: \n/\n/;
$BODY =~ s/<subject>/$SUBJECT/g;
$BODY =~ s/<package>/$PACKAGE_ARG/g;
$BODY =~ s/<version>/$PKG_VERSION/g;
$BODY =~ s/<package_and_version>/$PACKAGE_AND_VERSION/g;
$BODY =~ s/<from>/$FROM_ARG/g;
$BODY =~ s/\n<deadline>/$DEADLINE_ARG/g;

## Check every file with .po extension in $PODIR ...
Verbose("Checking for PO files in $PODIR");
opendir(DIR, $PODIR);
my $poFiles = {};
foreach my $poFile (grep(/\.po$/, readdir(DIR))) {
	local $/ = "\n\n";
	$poFiles->{$poFile} = {};
	my $outdated = 0;
	my $found_header = 0;
	open (PO, "< $PODIR/$poFile")
		or die "Unable to read $PODIR/$poFile: $!\n";
	while (<PO>) {
		if ($found_header == 0 && m/msgid ""\nmsgstr/s) {
			$found_header = 1;
			#  Concatenate lines
			s/"\n"//g;
			if (m/\\nLast-Translator: (.*?)\\n/ && $1 ne 'FULL NAME <EMAIL@ADDRESS>') {
				$poFiles->{$poFile}->{translator} = $1;
			} else {
				$warn .= "Warning: $poFile:  Unable to determine last translator.  Skipping file!\n";
				last;
			}
			if (m/\\nContent-Type: [^;]*; charset=(.*?)\\n/) {
				$poFiles->{$poFile}->{charset} = $1;
			} else {
				$warn .= "Warning: $poFile:  Unable to determine charset.  Skipping file!\n";
				last;
			}
			if ($LANGUAGETEAM_ARG && m/\\nLanguage-Team: (.*?)\\n/) {
				$poFiles->{$poFile}->{team} = $1
					if $1 ne 'LANGUAGE <LL@li.org>';
			}
			next;
		}
		#  Ignore outdated msgids
		next unless m/^msgid /m;
		#  Check for fuzzy or missing translations
		s/\n+$//s;
		if (m/^#, .*fuzzy/m or m/\nmsgstr ""$/s) {
			$outdated = 1;
			last;
		}
	}
	close (PO)
		or die "Unable to close $PODIR/$poFile: $!\n";
	delete $poFiles->{$poFile} unless $outdated;
}
closedir(DIR);
if (keys %$poFiles) {
	print "Outdated files: ".join(' ', keys %$poFiles)."\n";
} else {
	print "No outdated files\n";
	exit(0);
}

my $filelist = '';
if ($SUBMIT_ARG) {
	$filelist = join(' ', keys %$poFiles)."\n";
} else {
	foreach my $poFile (keys %$poFiles) {
		$filelist .= '### ' . $poFile . ': ' . $poFiles->{$poFile}->{translator};
		$filelist .= ', ' . $poFiles->{$poFile}->{team} if defined($poFiles->{$poFile}->{team});
		$filelist .= "\n";
	}
	#  Remove non-ASCII characters
	$filelist =~ s/[\x80-\xff]/?/g;
}
$BODY =~ s/<filelist>\n/$filelist/g;

my %headers = ();
if ($TEMPLATE_ARG eq "") {
	$BODY = &OpenEditor($EDITOR, $BODY) if not $DEFAULT_ARG;
} else {
	$BODY = &ReadFile($TEMPLATE_ARG);
}
%headers = &ParseHeaders($BODY);
$BODY = &RemoveHeaders($BODY);

print STDERR $warn if $warn ne '';

my @mails = ();
if ($SUBMIT_ARG) {
	$BODY =~ s/<filelist>/$filelist/g;
	my %mail = (
		From => $FROM_ARG,
		To => "maintonly\@bugs.debian.org",
		Subject => $SUBJECT,
		'X-Mail-Originator' => "$PROGRAM $VERSION"
	);
	$mail{body} = encode_qp($BODY);
	@mails = (\%mail);
} else {
	$BODY = encode_qp($BODY);
	my $ext = ($GZIP_ARG ? '.gz' : '');
	foreach my $file (keys %$poFiles) {
		my $content = &ReadFile($PODIR . "/" . $file);
		$content = Compress::Zlib::memGzip($content) if $GZIP_ARG;
		my $file_encoded = encode_base64($content);
		my $contentType = ($GZIP_ARG ? "application/octet-stream" : "text/x-gettext; name=\"$file\"; charset=\"$poFiles->{$file}->{charset}\"");
		my %mail = (
			From => $FROM_ARG,
			To => $poFiles->{$file}->{translator},
			Subject => $SUBJECT,
			'X-Mail-Originator' => "$PROGRAM $VERSION"
		);
		$mail{To} .= ", ". $poFiles->{$file}->{team}
			if defined $poFiles->{$file}->{team};

		my $boundary = "=" . time() . "=";
		$mail{'content-type'} = "multipart/mixed; boundary=\"$boundary\"";
		$mail{body} = <<_EOF_;
--$boundary
Content-Type: text/plain; charset="us-ascii"
Content-Transfer-Encoding: quoted-printable

$BODY

--$boundary
Content-Type: $contentType
Content-Transfer-Encoding: base64
Content-Disposition: attachment; filename="$file$ext"

$file_encoded
--$boundary--
_EOF_

		push(@mails, \%mail);
	}
}

#  Add mail headers and remove non-ASCII characters
foreach my $refmail (@mails) {
	foreach my $h (keys(%headers)) {
		$refmail->{$h} = &DropNonASCII($headers{$h});
	}
	foreach my $h (qw(From To Subject)) {
		$refmail->{$h} = &DropNonASCII($refmail->{$h});
	}
	$refmail->{smtp} = $SMTP_ARG if ($SMTP_ARG ne '');
}

if (!$FORCE_ARG) {
	if ($SUBMIT_ARG) {
		print "Ready to send the bug report against the package $PACKAGE_ARG, are you sure? [y/N] ";
	} else {
		print "Ready to send the emails, are you sure? [y/N] ";
	}
	my $line = <>;
	chop $line;
	exit(0) if ($line ne "Y" and $line ne "y");
}

#  Make Perl compiler quiet
print $Mail::Sendmail::error . $Mail::Sendmail::error if 0;
foreach my $mail (@mails) {
	sendmail(%{$mail}) || print "Couldn't send the email: $Mail::Sendmail::error\n";
}
exit(0);

###############################################################################

sub OpenEditor
{
	my $editor = shift;
	my $body = shift;
	my $opts = "";
	my $tmpnam = tmpnam();

	open (OUT, "> $tmpnam")
		or die ("Couldn't write $tmpnam: $!\nExiting!\n");
	print OUT $body;
	close(OUT)
		or die ("Couldn't close $tmpnam: $!\nExiting!\n");

	$opts = "-f" if ($editor eq "vim");
	system("$editor $opts $tmpnam");

	$body = &ReadFile($tmpnam) if (-f $tmpnam);
	unlink($tmpnam);

	return $body;
}

sub ParseHeaders
{
	my $body = shift;
	my %headers = ();

	while ($body =~ s/^#[ \t]*([^\n]*)\n//s) {
		my $comment = $1;
		if ($comment =~ m/^([a-zA-Z0-9_-]+):\s*([^\n]+)$/) {
			$headers{$1} = $2;
		}
	}
	return %headers;
}

sub RemoveHeaders
{
	my $body = shift;
	#  First remove comments
	1 while $body =~ s/^#[^\n]*\n//s;
	#  Optional empty lines
	$body =~ s/^\s+//s;
	return $body;
}

sub DropNonASCII {
	my $text = shift;
	$text =~ s/[\x80-\xff]/?/g;
	return $text;
}

sub ReadFile
{
	my $file = shift;
	local $/ = undef;
	open(FILE, "< $file")
		or die ("Couldn't read $file: $!\nExiting!\n");
	my $body = <FILE>;
	close(FILE)
		or die ("Couldn't close $file: $!\nExiting!\n");
	return $body;
}

## Handle invalid arguments
sub Help_InvalidOption
{
	print STDERR "Try `${PROGRAM} --help' for more information.\n";
	exit 1;
}

## Print the usage message and exit
sub Help_PrintHelp
{
	print <<_EOF_;

Usage: ${PROGRAM} [OPTIONS]
Send outdated debconf PO files to the last translators.

Options:
  --help                display this help and exit
  --version             display version information and exit
  -v, --verbose         display additional information
  -f, --force           send the email without confirmation
  --podir=DIRECTORY     specify where are located the PO files
  --smtp=SERVER         specify SMTP server for mailing (default localhost)
  --template=TEMPLATE   specify file to use it as template for the emails
  --default             don't open the editor and use the template as is
  --gzip                compress PO files with gzip
  --package=PACKAGE     specify the name of the package
  --from=MAINTAINER     specify the name and the email address of the sender
  --deadline=DEADLINE   specify the deadline for receiving the updated
                        translations
  --languageteam        send the email also to the Language Team
  --submit              send a bug report against the package with a report
                        of the outdated debconf translations
  --bts=BUGNUMBER       specify the Debian bug number to set as reply-to

_EOF_
	exit 0;
}

## Print the version text and exit
sub Help_PrintVersion
{
	print <<_EOF_;
${PROGRAM} $VERSION
Copyright (C) 2004, 2005 Fabio Tranchitella and Denis Barbier.
This is free software; see the source for copying conditions.  There is NO
warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
_EOF_
	exit 0;
}

sub Verbose
{
	my $msg = shift;
	return unless $VERBOSE_ARG;
	$msg =~ s/^/**${PROGRAM}: /mg;
	print STDERR $msg."\n";
}
