| 1 |
#!/usr/bin/perl
|
| 2 |
#
|
| 3 |
# This is a little utility designed to keep track of translations
|
| 4 |
# in the Debian web site Subversion repository.
|
| 5 |
#
|
| 6 |
## For information about translation revisions please see
|
| 7 |
## http://www.debian.org/devel/website/uptodate
|
| 8 |
#
|
| 9 |
# Copyright (C) 2008 Bas Zoetekouw <bas@debian.org>
|
| 10 |
# Based on on code from:
|
| 11 |
# Copyright (C) 1998 Paolo Molaro <lupus@debian.org>
|
| 12 |
# Copyright (C) 1999-2003 Peter Karlsson <peterk@debian.org>
|
| 13 |
# Copyright (C) 2000,2001 Martin Quinson <mquinson@ens-lyon.fr>
|
| 14 |
#
|
| 15 |
# This program is free software; you can redistribute it and/or modify
|
| 16 |
# it under the terms of version 2 of the GNU General Public License as
|
| 17 |
# published by the Free Software Foundation.
|
| 18 |
#
|
| 19 |
## This program is distributed in the hope that it will be useful, but
|
| 20 |
## WITHOUT ANY WARRANTY; without even the implied warranty of
|
| 21 |
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
| 22 |
## General Public License for more details.
|
| 23 |
#
|
| 24 |
#
|
| 25 |
# Invocation:
|
| 26 |
# check_trans.pl [-vqdlM] [-C dir] [-p pattern] [-s subtree]
|
| 27 |
# [-m email -n N] [-c charset] [-g] [-t outputtype]
|
| 28 |
# [language]
|
| 29 |
#
|
| 30 |
# It needs to be run from the top level webwml directory.
|
| 31 |
# If you don't specify a language on the command line, the language name
|
| 32 |
# will be loaded from a file called language.conf, if such a file exists.
|
| 33 |
#
|
| 34 |
# For example:
|
| 35 |
# $ check_trans.pl -v italian
|
| 36 |
# You may also check only some subtrees as in:
|
| 37 |
# $ check_trans.pl -s devel italian
|
| 38 |
#
|
| 39 |
# Options:
|
| 40 |
# -Q be really quiet (only show errors/warnings on stderr)
|
| 41 |
# -q just don't whine about missing files
|
| 42 |
# -v show the status of all files (verbose)
|
| 43 |
# -V output what we're doing (very verbose)
|
| 44 |
# -d output diffs
|
| 45 |
# -l output log messages
|
| 46 |
# -T output translated diffs
|
| 47 |
# -p <pattern> include only files matching <pattern>,
|
| 48 |
# default is *.src|*.wml
|
| 49 |
# -s <subtree> check only that subtree
|
| 50 |
# -a output age of translation (if older than 2 months)
|
| 51 |
#
|
| 52 |
# Options useful when sending mails:
|
| 53 |
# -m <email> sends mails to translation maintainers
|
| 54 |
# PLEASE CAREFULLY READ THE BELOW TEXT ABOUT MAKING MAILS!
|
| 55 |
# <email> is the default recipient
|
| 56 |
# (it should be the list used for organisation,
|
| 57 |
# e.g. debian-l10n-french@lists.debian.org)
|
| 58 |
# -g debuG mail send process
|
| 59 |
# -n <1|2|3> send mails of priority upper or equal to
|
| 60 |
# 1 (monthly), 2 (weekly) or 3 (daily)
|
| 61 |
#
|
| 62 |
# generating emails
|
| 63 |
# If you want to, this script send mails to the maintainer of the mails.
|
| 64 |
# BEWARE, SOME PEOPLE DO NOT LIKE TO RECEIVE AUTOMATIC MAILS!
|
| 65 |
#
|
| 66 |
# PREREQUISITES:
|
| 67 |
# You will need one database:
|
| 68 |
# - one in which to get info about translators and the frequency at
|
| 69 |
# which they want to get mails. It must be named
|
| 70 |
# webwml/$langto/international/$langto/translator.db.pl
|
| 71 |
# Please refer to the French one for more info.
|
| 72 |
#
|
| 73 |
# USAGE:
|
| 74 |
# If you give the "-g" option, all mails are sent to the default addressee
|
| 75 |
# (i.e. the one given as value to the -m option), without respect to their
|
| 76 |
# normal addressee. It is useful if you want to run it for yourself,
|
| 77 |
# and for debugging.
|
| 78 |
# Without that option, it sends real mails to real addresses.
|
| 79 |
# MAKE SURE THE ADDRESSEES REALLY WANT TO GET THESE MAILS
|
| 80 |
|
| 81 |
use Getopt::Std;
|
| 82 |
use File::Basename;
|
| 83 |
use File::Spec::Functions;
|
| 84 |
use Term::ANSIColor;
|
| 85 |
use Encode;
|
| 86 |
#use Data::Dumper;
|
| 87 |
use FindBin;
|
| 88 |
FindBin::again();
|
| 89 |
|
| 90 |
# These modules reside under webwml/Perl
|
| 91 |
use lib "$FindBin::Bin/Perl";
|
| 92 |
use Local::VCS ':all';
|
| 93 |
use Local::Util qw/ uniq read_file /;
|
| 94 |
use Local::WmlDiffTrans;
|
| 95 |
use Webwml::TransCheck;
|
| 96 |
use Webwml::TransIgnore;
|
| 97 |
|
| 98 |
use strict;
|
| 99 |
use warnings;
|
| 100 |
|
| 101 |
|
| 102 |
|
| 103 |
# misc hardcoded things
|
| 104 |
my $MY_EMAIL = q{Debian WWW translation watch <debian-www@lists.debian.org>};
|
| 105 |
my $DEFAULT_PATTERN = '(?:\.wml|\.src)$';
|
| 106 |
|
| 107 |
# global variable to record verbosity
|
| 108 |
my $VERBOSE = 0;
|
| 109 |
|
| 110 |
# status codes
|
| 111 |
use constant {
|
| 112 |
ST_MISSING => 1,
|
| 113 |
ST_NEEDSUPDATE => 3,
|
| 114 |
ST_UPTODATE => 4,
|
| 115 |
ST_NOTATRANSL => 5,
|
| 116 |
ST_BROKEN => 6,
|
| 117 |
ST_OBSOLETE => 7,
|
| 118 |
ST_UNDEFINED => 8,
|
| 119 |
};
|
| 120 |
|
| 121 |
# how to colour each different status
|
| 122 |
my %COLOURS = (
|
| 123 |
main::ST_MISSING => 'magenta',
|
| 124 |
main::ST_NEEDSUPDATE => 'blue',
|
| 125 |
main::ST_UPTODATE => 'green',
|
| 126 |
main::ST_NOTATRANSL => 'yellow',
|
| 127 |
main::ST_BROKEN => 'red',
|
| 128 |
main::ST_OBSOLETE => 'red',
|
| 129 |
main::ST_UNDEFINED => 'red',
|
| 130 |
'warn' => 'bold red',
|
| 131 |
);
|
| 132 |
|
| 133 |
# these is called in "main" so needs to be declared here
|
| 134 |
sub switch_var(\$\$);
|
| 135 |
sub verbose;
|
| 136 |
|
| 137 |
#=================================================
|
| 138 |
#== "main"
|
| 139 |
#==
|
| 140 |
{
|
| 141 |
my ($language,$file_pattern,%OPT) = parse_cmdargs();
|
| 142 |
my %translators = read_translators( $language, $OPT{m} );
|
| 143 |
my %emails_to_send;
|
| 144 |
|
| 145 |
# -s allows the user to restrict processing to a subtree
|
| 146 |
my $english_path = 'english';
|
| 147 |
my $language_path = $language;
|
| 148 |
|
| 149 |
my $subdir = $OPT{'s'} || undef;
|
| 150 |
|
| 151 |
# Global .transignore
|
| 152 |
my $transignore = Webwml::TransIgnore->new( vcs_get_topdir );
|
| 153 |
|
| 154 |
# first get a list with revision information from all files in english...
|
| 155 |
my %english_revs = vcs_path_info( $english_path,
|
| 156 |
'recursive' => 1,
|
| 157 |
'match_pat' => $file_pattern,
|
| 158 |
);
|
| 159 |
# ... and the translation
|
| 160 |
my %translation_revs = vcs_path_info( $language_path,
|
| 161 |
'recursive' => 1,
|
| 162 |
'match_pat' => $file_pattern,
|
| 163 |
);
|
| 164 |
|
| 165 |
# construct a list with all files that either occur in english or
|
| 166 |
# in the translation
|
| 167 |
my @files = uniq ( keys %english_revs, keys %translation_revs );
|
| 168 |
|
| 169 |
|
| 170 |
# now check each of the files
|
| 171 |
foreach my $file (sort @files)
|
| 172 |
{
|
| 173 |
# ignore this file?
|
| 174 |
next if $transignore->is_global( $file );
|
| 175 |
next if $subdir and not $file =~ m{^$subdir};
|
| 176 |
|
| 177 |
# note: $language is the name of the current language we're
|
| 178 |
# processing, whereas $transl is the name of the language which the
|
| 179 |
# current file is translated into (which might be english!)
|
| 180 |
my $orig = 'english';
|
| 181 |
my $transl = $language;
|
| 182 |
|
| 183 |
my $file_orig = catfile( $orig, $file );
|
| 184 |
my $file_transl = catfile( $transl, $file );
|
| 185 |
|
| 186 |
my $revinfo_orig = $english_revs{$file};
|
| 187 |
my $revinfo_transl = $translation_revs{$file};
|
| 188 |
|
| 189 |
# TODO: put this in a separate function
|
| 190 |
# first we check if the translated file has an origin other than
|
| 191 |
# english
|
| 192 |
if ( -e $file_transl )
|
| 193 |
{
|
| 194 |
my $transcheck = Webwml::TransCheck->new( $file_transl );
|
| 195 |
my $original_lang = $transcheck->original();
|
| 196 |
|
| 197 |
if ( $original_lang and $original_lang ne 'english' )
|
| 198 |
{
|
| 199 |
die( "Unknown original language `$original_lang' "
|
| 200 |
."for `$file_transl'\n" ) unless -d $original_lang;
|
| 201 |
|
| 202 |
verbose "`$file_transl' is translated from $original_lang";
|
| 203 |
|
| 204 |
# now, we use the correct (non-english) original file
|
| 205 |
$file_orig = catfile( $original_lang, $file );
|
| 206 |
|
| 207 |
# and find the correct revision info for this file
|
| 208 |
$revinfo_orig = { vcs_file_info( $file_orig ) };
|
| 209 |
}
|
| 210 |
}
|
| 211 |
|
| 212 |
# TODO: put this in a separate function
|
| 213 |
# secondly, we check if perhaps the original file is a translation
|
| 214 |
# (such as in the case of english/international/Swedish/index.wml)
|
| 215 |
if ( -e $file_transl and -e $file_orig )
|
| 216 |
{
|
| 217 |
my $transcheck = Webwml::TransCheck->new( $file_orig );
|
| 218 |
my $original_lang = $transcheck->original();
|
| 219 |
my $rev = $transcheck->revision();
|
| 220 |
|
| 221 |
if ( $rev )
|
| 222 |
{
|
| 223 |
## This check is too strict: some translators like to translate
|
| 224 |
##from other translations rather than from the original english
|
| 225 |
##(see e.g., danish/international/Norwegian.wml)
|
| 226 |
#if ( not $original_lang )
|
| 227 |
#{
|
| 228 |
# # TODO: ideally, this would also be mailed out to the
|
| 229 |
# # translation team
|
| 230 |
# warn "`$file_orig' has a revision header but no origin language\n";
|
| 231 |
# next;
|
| 232 |
#}
|
| 233 |
|
| 234 |
if ( $original_lang and $original_lang eq $language )
|
| 235 |
{
|
| 236 |
verbose "`$file_orig' is a translation from $language";
|
| 237 |
|
| 238 |
# switch $orig and $transl
|
| 239 |
switch_var( $orig, $transl );
|
| 240 |
switch_var( $file_orig, $file_transl );
|
| 241 |
switch_var( $revinfo_orig, $revinfo_transl );
|
| 242 |
}
|
| 243 |
}
|
| 244 |
|
| 245 |
}
|
| 246 |
|
| 247 |
# determine the status of the file
|
| 248 |
my ($status,$str,$rev_transl,$maintainer,$maxdelta) = check_file(
|
| 249 |
$file,
|
| 250 |
$orig, $transl,
|
| 251 |
$revinfo_orig, $revinfo_transl,
|
| 252 |
);
|
| 253 |
|
| 254 |
|
| 255 |
######################################################################
|
| 256 |
## Everything below is just output logic
|
| 257 |
######################################################################
|
| 258 |
|
| 259 |
# print info
|
| 260 |
if ( ( $OPT{v} )
|
| 261 |
or ( $status == ST_MISSING and not $OPT{q} )
|
| 262 |
or ( $status != ST_MISSING and $status != ST_UPTODATE
|
| 263 |
and $status != ST_NOTATRANSL )
|
| 264 |
)
|
| 265 |
{
|
| 266 |
print colored( "$str\n", $COLOURS{$status} );
|
| 267 |
}
|
| 268 |
|
| 269 |
# check age of the translation
|
| 270 |
if ( $OPT{a} and $status == ST_NEEDSUPDATE )
|
| 271 |
{
|
| 272 |
my $age = int get_revision_age( $revinfo_transl );
|
| 273 |
|
| 274 |
# only warn if the translation is older than 2 weeks
|
| 275 |
if ( $age > 14 )
|
| 276 |
{
|
| 277 |
print colored( "$file is outdated by $age days\n",
|
| 278 |
$COLOURS{warn} );
|
| 279 |
}
|
| 280 |
}
|
| 281 |
|
| 282 |
# print diff if requested and an update is needed
|
| 283 |
if ( $OPT{'d'} and $status == ST_NEEDSUPDATE )
|
| 284 |
{
|
| 285 |
my $diff = get_diff(
|
| 286 |
$file_orig,
|
| 287 |
$rev_transl,
|
| 288 |
$revinfo_orig->{'cmt_rev'},
|
| 289 |
);
|
| 290 |
print $diff;
|
| 291 |
}
|
| 292 |
|
| 293 |
# print text diff, if requested and an update is needed
|
| 294 |
if ( $OPT{'T'} and $status == ST_NEEDSUPDATE )
|
| 295 |
{
|
| 296 |
my $diff = get_diff_txt(
|
| 297 |
$file_orig,
|
| 298 |
$rev_transl,
|
| 299 |
$revinfo_orig->{'cmt_rev'},
|
| 300 |
$file_transl
|
| 301 |
);
|
| 302 |
print $diff;
|
| 303 |
}
|
| 304 |
|
| 305 |
|
| 306 |
# prepare a mail to be sent
|
| 307 |
if ( $OPT{'m'} and $status != ST_UPTODATE )
|
| 308 |
{
|
| 309 |
# handle special case maintainer fields
|
| 310 |
$maintainer = 'unmaintained'
|
| 311 |
unless $maintainer and exists $translators{$maintainer};
|
| 312 |
$maintainer = 'untranslated'
|
| 313 |
if $status == ST_MISSING;
|
| 314 |
|
| 315 |
# mail to send to the maintainer
|
| 316 |
push @{ $emails_to_send{$maintainer} }, {
|
| 317 |
'file' => $file,
|
| 318 |
'status' => $status,
|
| 319 |
'info' => $str,
|
| 320 |
'last_trans_rev' => $rev_transl,
|
| 321 |
}
|
| 322 |
if ( exists $translators{$maintainer} );
|
| 323 |
|
| 324 |
# mail for maxdelta
|
| 325 |
if ( $status != ST_MISSING )
|
| 326 |
{
|
| 327 |
$maxdelta ||= $translators{maxdelta}{maxdelta} || 5;
|
| 328 |
|
| 329 |
my $delta = undef;
|
| 330 |
if ( -e $file_orig )
|
| 331 |
{
|
| 332 |
$delta = vcs_count_changes( $file_orig, $rev_transl, 'HEAD' );
|
| 333 |
|
| 334 |
push @{ $emails_to_send{'maxdelta'} }, {
|
| 335 |
'file' => $file,
|
| 336 |
'status' => $status,
|
| 337 |
'info' => $str,
|
| 338 |
'delta' => $delta,
|
| 339 |
'last_trans_rev' => $rev_transl,
|
| 340 |
}
|
| 341 |
if ( $delta >= $maxdelta );
|
| 342 |
}
|
| 343 |
}
|
| 344 |
|
| 345 |
}
|
| 346 |
|
| 347 |
}
|
| 348 |
|
| 349 |
send_email( \%emails_to_send, \%translators, $language, $OPT{'n'}, !$OPT{'g'} );
|
| 350 |
|
| 351 |
exit 0;
|
| 352 |
}
|
| 353 |
die("Never reached");
|
| 354 |
|
| 355 |
|
| 356 |
#=================================================
|
| 357 |
#== swich two variables around
|
| 358 |
#==
|
| 359 |
sub switch_var(\$\$)
|
| 360 |
{
|
| 361 |
my $a = shift;
|
| 362 |
my $b = shift;
|
| 363 |
|
| 364 |
my $c = $$a;
|
| 365 |
$$a = $$b;
|
| 366 |
$$b = $c;
|
| 367 |
}
|
| 368 |
|
| 369 |
|
| 370 |
#=================================================
|
| 371 |
#== output verbose messages
|
| 372 |
#==
|
| 373 |
sub verbose
|
| 374 |
{
|
| 375 |
return unless $VERBOSE;
|
| 376 |
print @_, "\n";
|
| 377 |
}
|
| 378 |
|
| 379 |
|
| 380 |
|
| 381 |
#=================================================
|
| 382 |
#== send out the emails
|
| 383 |
#==
|
| 384 |
sub send_email
|
| 385 |
{
|
| 386 |
my $emails = shift or die("No emails specified");
|
| 387 |
my $translators = shift or die("No translators specified");
|
| 388 |
my $lang = shift or die("No language specified");
|
| 389 |
my $priority = shift or die("No priority specified");
|
| 390 |
my $really_send = shift || 0;
|
| 391 |
|
| 392 |
|
| 393 |
foreach my $name (sort keys %$emails)
|
| 394 |
{
|
| 395 |
verbose("Preparing email for $name");
|
| 396 |
|
| 397 |
# skip unconfigured users
|
| 398 |
if ( not exists $translators->{$name}
|
| 399 |
or not $translators->{$name}{'email'} )
|
| 400 |
{
|
| 401 |
verbose( "Woops! Can't find info for user `$name'\n" );
|
| 402 |
next;
|
| 403 |
}
|
| 404 |
|
| 405 |
# check the user's email addres
|
| 406 |
if ( not Email::Address->parse( $translators->{$name}{'email'} ) )
|
| 407 |
{
|
| 408 |
printf STDERR "Can't parse email address `%s' for %s!\n",
|
| 409 |
$translators->{$name}{'email'}, $name;
|
| 410 |
next;
|
| 411 |
}
|
| 412 |
|
| 413 |
# skip if the user doesn't want a summary at all
|
| 414 |
if ( $translators->{$name}{'summary'} < $priority )
|
| 415 |
{
|
| 416 |
verbose( "Not sending message to $name (prio "
|
| 417 |
. $translators->{$name}{'summary'} . " < $priority)" );
|
| 418 |
next;
|
| 419 |
}
|
| 420 |
|
| 421 |
my %transl = %{ $translators->{$name} };
|
| 422 |
|
| 423 |
#print Dumper($emails->{$name});
|
| 424 |
|
| 425 |
my $msg = MIME::Lite->new(
|
| 426 |
'From' => $MY_EMAIL,
|
| 427 |
'To' => $translators->{$name}{'email'},
|
| 428 |
'Subject' => $translators->{$name}{'mailsubject'},
|
| 429 |
'Type' => 'multipart/mixed',
|
| 430 |
);
|
| 431 |
|
| 432 |
# read body and interpret perl that's embedded there
|
| 433 |
my $body = read_file_enc( $transl{'mailbody'} )
|
| 434 |
or die("Can't read $transl{'mailbody'}");
|
| 435 |
{
|
| 436 |
# a bit hackish, but I want to keep the curent format of
|
| 437 |
# the mail body files intact, for now
|
| 438 |
# so we need to use the same old variable names as the original
|
| 439 |
# script used
|
| 440 |
my %translators = %{$translators};
|
| 441 |
$body =~ s{#(.*?)#}{eval $1}mge;
|
| 442 |
}
|
| 443 |
|
| 444 |
# and attach the body to the mail
|
| 445 |
my $part = MIME::Lite->new(
|
| 446 |
'Type' => 'text/plain',
|
| 447 |
'Data' => $body,
|
| 448 |
);
|
| 449 |
$part->attr( 'content-type.charset' => 'utf-8' );
|
| 450 |
$msg->attach( $part );
|
| 451 |
|
| 452 |
# attach part about NeedToUpdate files
|
| 453 |
my $text = '';
|
| 454 |
foreach my $file ( @{ $emails->{$name} } )
|
| 455 |
{
|
| 456 |
next unless $file->{'status'} == ST_NEEDSUPDATE;
|
| 457 |
$text .= $file->{'info'};
|
| 458 |
|
| 459 |
if ( exists $file->{'delta'} )
|
| 460 |
{
|
| 461 |
$text .= sprintf( " [out of date by %d revisions]",
|
| 462 |
$file->{'delta'} );
|
| 463 |
}
|
| 464 |
|
| 465 |
$text .= "\n";
|
| 466 |
}
|
| 467 |
$msg->attach(
|
| 468 |
'Type' => 'TEXT',
|
| 469 |
'Filename' => 'NeedToUpdate summary',
|
| 470 |
'Data' => $text,
|
| 471 |
)
|
| 472 |
if $text;
|
| 473 |
|
| 474 |
# attach part about Missing files
|
| 475 |
$text = '';
|
| 476 |
foreach my $file ( @{ $emails->{$name} } )
|
| 477 |
{
|
| 478 |
next unless $file->{'status'} == ST_MISSING;
|
| 479 |
$text .= sprintf( "%s\n", $file->{'info'} );
|
| 480 |
}
|
| 481 |
$msg->attach(
|
| 482 |
'Type' => 'TEXT',
|
| 483 |
'Filename' => 'Missing summary',
|
| 484 |
'Data' => $text,
|
| 485 |
'Encoding' => 'quoted-printable',
|
| 486 |
)
|
| 487 |
if $text;
|
| 488 |
|
| 489 |
# add diffs, if requested
|
| 490 |
if ( $priority <= $translators->{$name}{'diff'} )
|
| 491 |
{
|
| 492 |
foreach my $file ( @{ $emails->{$name} } )
|
| 493 |
{
|
| 494 |
# diffs really only make sense if there is an existing
|
| 495 |
# translation
|
| 496 |
next unless $file->{'status'} == ST_NEEDSUPDATE;
|
| 497 |
|
| 498 |
my $filename = catfile( 'english', $file->{'file'} );
|
| 499 |
my $rev = $file->{'last_trans_rev'};
|
| 500 |
my $diff = get_diff( $filename, $rev, 'HEAD' );
|
| 501 |
$msg->attach(
|
| 502 |
'Type' => 'TEXT',
|
| 503 |
'Filename' => "$filename.diff",
|
| 504 |
'Data' => $diff,
|
| 505 |
'Encoding' => 'quoted-printable',
|
| 506 |
);
|
| 507 |
}
|
| 508 |
}
|
| 509 |
else
|
| 510 |
{
|
| 511 |
verbose( "Not attaching diffs (prio "
|
| 512 |
. $translators->{$name}{'diff'} . " < $priority)" );
|
| 513 |
}
|
| 514 |
|
| 515 |
# add tdiffs, if requested
|
| 516 |
if ( $priority <= $translators->{$name}{'tdiff'} )
|
| 517 |
{
|
| 518 |
foreach my $file ( @{ $emails->{$name} } )
|
| 519 |
{
|
| 520 |
# diffs really only make sense if there is an existing
|
| 521 |
# translation
|
| 522 |
next unless $file->{'status'} == ST_NEEDSUPDATE;
|
| 523 |
|
| 524 |
my $filename = catfile( 'english', $file->{'file'} );
|
| 525 |
my $filename2 = catfile( $lang, $file->{'file'} );
|
| 526 |
my $rev = $file->{'last_trans_rev'};
|
| 527 |
my $tdiff = get_diff_txt( $filename, $rev, 'HEAD',
|
| 528 |
$filename2 );
|
| 529 |
$msg->attach(
|
| 530 |
'Type' => 'TEXT',
|
| 531 |
'Filename' => "$filename.tdiff",
|
| 532 |
'Data' => $tdiff,
|
| 533 |
'Encoding' => 'quoted-printable',
|
| 534 |
);
|
| 535 |
}
|
| 536 |
}
|
| 537 |
else
|
| 538 |
{
|
| 539 |
verbose( "Not attaching tdiffs (prio "
|
| 540 |
. $translators->{$name}{'tdiff'} . " < $priority)" );
|
| 541 |
}
|
| 542 |
|
| 543 |
# add logs, if requested
|
| 544 |
if ( $priority <= $translators->{$name}{'logs'} )
|
| 545 |
{
|
| 546 |
foreach my $file ( @{ $emails->{$name} } )
|
| 547 |
{
|
| 548 |
# logs really only make sense if there is an existing
|
| 549 |
# translation
|
| 550 |
next unless $file->{'status'} == ST_NEEDSUPDATE;
|
| 551 |
|
| 552 |
my $filename = catfile( 'english', $file->{'file'} );
|
| 553 |
my $rev = $file->{'last_trans_rev'};
|
| 554 |
my $log = get_log( $filename, $rev, 'HEAD' );
|
| 555 |
my $part = MIME::Lite->new(
|
| 556 |
'Type' => 'TEXT',
|
| 557 |
'Filename' => "$filename.log",
|
| 558 |
'Data' => $log,
|
| 559 |
'Encoding' => 'quoted-printable',
|
| 560 |
);
|
| 561 |
$part->attr( 'content-type.charset' => 'utf-8' );
|
| 562 |
$msg->attach( $part );
|
| 563 |
}
|
| 564 |
}
|
| 565 |
else
|
| 566 |
{
|
| 567 |
verbose( "Not attaching logs (prio "
|
| 568 |
. $translators->{$name}{'logs'} . " < $priority)" );
|
| 569 |
}
|
| 570 |
|
| 571 |
# add file, if requested
|
| 572 |
if ( $priority <= $translators->{$name}{'file'} )
|
| 573 |
{
|
| 574 |
foreach my $file ( @{ $emails->{$name} } )
|
| 575 |
{
|
| 576 |
my $filename = catfile( $lang, $file->{'file'} );
|
| 577 |
my $part = MIME::Lite->new(
|
| 578 |
'Type' => 'text/wml',
|
| 579 |
'Filename' => $filename,
|
| 580 |
'Path' => $filename,
|
| 581 |
'Encoding' => 'quoted-printable',
|
| 582 |
);
|
| 583 |
$part->attr( 'content-type.charset' => get_file_charset($filename) );
|
| 584 |
$msg->attach( $part );
|
| 585 |
|
| 586 |
}
|
| 587 |
}
|
| 588 |
else
|
| 589 |
{
|
| 590 |
verbose( "Not attaching files (prio "
|
| 591 |
. $translators->{$name}{'file'} . " < $priority)" );
|
| 592 |
}
|
| 593 |
|
| 594 |
|
| 595 |
|
| 596 |
# check if we really want to send the mail
|
| 597 |
if ( $really_send )
|
| 598 |
{
|
| 599 |
verbose 'Sending email to ' . $translators->{$name}{'email'};
|
| 600 |
$msg->send or warn("Couldn't send message to $name");
|
| 601 |
}
|
| 602 |
else
|
| 603 |
{
|
| 604 |
print $msg->as_string;
|
| 605 |
}
|
| 606 |
}
|
| 607 |
}
|
| 608 |
|
| 609 |
|
| 610 |
#=================================================
|
| 611 |
#== return the age of the revision (in days)
|
| 612 |
#==
|
| 613 |
sub get_revision_age
|
| 614 |
{
|
| 615 |
my $rev_info = shift;
|
| 616 |
|
| 617 |
die("No revision info specified") unless ref $rev_info eq 'HASH';
|
| 618 |
|
| 619 |
my $rev_timestamp = $rev_info->{'cmt_date'};
|
| 620 |
my $age = time - $rev_timestamp;
|
| 621 |
|
| 622 |
warn( "Timestamp is in the future!" ) if $age < 0;
|
| 623 |
|
| 624 |
# return age in days
|
| 625 |
return $age / ( 60*60*24 );
|
| 626 |
}
|
| 627 |
|
| 628 |
|
| 629 |
|
| 630 |
#=================================================
|
| 631 |
#== get a log
|
| 632 |
#==
|
| 633 |
sub get_log
|
| 634 |
{
|
| 635 |
my $file = shift or die("No file specified for diff");
|
| 636 |
my $rev1 = shift;
|
| 637 |
my $rev2 = shift;
|
| 638 |
|
| 639 |
die("NO such file `$file'") unless -e $file;
|
| 640 |
|
| 641 |
my @log = vcs_get_log( $file, $rev1, $rev2 );
|
| 642 |
|
| 643 |
# remove the first item of the log, because we only want
|
| 644 |
# to see when changed in the (left-open) range (rev1,rev2]
|
| 645 |
shift @log;
|
| 646 |
|
| 647 |
# format it nicely
|
| 648 |
my $str = '-' x 78 . "\n";
|
| 649 |
foreach my $l (@log)
|
| 650 |
{
|
| 651 |
chomp $l->{'message'};
|
| 652 |
|
| 653 |
$str .= sprintf( "%s | %s | %s\n",
|
| 654 |
$l->{'rev'}, $l->{'author'}, scalar localtime $l->{'date'} );
|
| 655 |
$str .= "\n";
|
| 656 |
$str .= $l->{'message'} . "\n";
|
| 657 |
$str .= "\n";
|
| 658 |
|
| 659 |
$str .= '-' x 78 . "\n";
|
| 660 |
|
| 661 |
}
|
| 662 |
|
| 663 |
|
| 664 |
return $str;
|
| 665 |
}
|
| 666 |
|
| 667 |
#=================================================
|
| 668 |
#== get a diff
|
| 669 |
#==
|
| 670 |
sub get_diff
|
| 671 |
{
|
| 672 |
my $file = shift or die("No file specified for diff");
|
| 673 |
my $rev1 = shift;
|
| 674 |
my $rev2 = shift;
|
| 675 |
|
| 676 |
die("NO such file `$file'") unless -e $file;
|
| 677 |
|
| 678 |
my %diffs = vcs_get_diff( $file, $rev1, $rev2 );
|
| 679 |
|
| 680 |
# just glue all diffs together and return it as a big string
|
| 681 |
my $difftxt = join( '', values %diffs );
|
| 682 |
|
| 683 |
return $difftxt;
|
| 684 |
}
|
| 685 |
|
| 686 |
#=================================================
|
| 687 |
#== get a diff while trying to match html tags
|
| 688 |
#==
|
| 689 |
sub get_diff_txt
|
| 690 |
{
|
| 691 |
my $english_file = shift or die("No file specified");
|
| 692 |
my $rev1 = shift or die("No revision specified");
|
| 693 |
my $rev2 = shift or die("No revision specified");
|
| 694 |
my $transl_file = shift or die("No transl file specified");
|
| 695 |
|
| 696 |
die("No such file $english_file") unless -e $english_file;
|
| 697 |
die("No such file $transl_file") unless -e $transl_file;
|
| 698 |
|
| 699 |
# Get old revision file
|
| 700 |
my @english_txt = split( "\n", vcs_get_file( $english_file, $rev1 ) );
|
| 701 |
|
| 702 |
# Get translation file
|
| 703 |
my $transl_txt = read_file( $transl_file )
|
| 704 |
or die("Couln't read `$transl_file': $!");
|
| 705 |
my @transl_txt = split( "\n", $transl_txt );
|
| 706 |
|
| 707 |
# Get diff lines
|
| 708 |
my @diff_txt = split( "\n", get_diff( $english_file, $rev1, $rev2 ) );
|
| 709 |
|
| 710 |
# do the matching
|
| 711 |
my $txt = Local::WmlDiffTrans::find_trans_parts(
|
| 712 |
\@english_txt,
|
| 713 |
\@transl_txt,
|
| 714 |
\@diff_txt
|
| 715 |
);
|
| 716 |
|
| 717 |
return $txt;
|
| 718 |
}
|
| 719 |
|
| 720 |
|
| 721 |
#=================================================
|
| 722 |
#== show help from the top of this file
|
| 723 |
#==
|
| 724 |
sub show_help
|
| 725 |
{
|
| 726 |
# read the help from the comments above and display it
|
| 727 |
open( my $me, '<', $0 ) or die "Unable to display help: $!\n";
|
| 728 |
|
| 729 |
while (<$me>)
|
| 730 |
{
|
| 731 |
last if m{^use};
|
| 732 |
next unless m{^# };
|
| 733 |
|
| 734 |
s{^# ?}{};
|
| 735 |
|
| 736 |
print;
|
| 737 |
}
|
| 738 |
|
| 739 |
close( $me );
|
| 740 |
}
|
| 741 |
|
| 742 |
|
| 743 |
#=================================================
|
| 744 |
#== parse command line options and read defaults
|
| 745 |
#==
|
| 746 |
sub parse_cmdargs
|
| 747 |
{
|
| 748 |
my %OPT;
|
| 749 |
$OPT{n} = 5; # an invalid default
|
| 750 |
$OPT{s} = '';
|
| 751 |
|
| 752 |
# parse options
|
| 753 |
if ( not getopts( 'adghm:n:p:Qqs:TvV', \%OPT ) )
|
| 754 |
{
|
| 755 |
show_help();
|
| 756 |
exit -1;
|
| 757 |
}
|
| 758 |
|
| 759 |
# show help
|
| 760 |
if ( $OPT{h} )
|
| 761 |
{
|
| 762 |
show_help();
|
| 763 |
exit 0;
|
| 764 |
}
|
| 765 |
|
| 766 |
# handle verbosity setting
|
| 767 |
if ( ( $OPT{'v'} or $OPT{'V'} ) and ( $OPT{'q'} or $OPT{'Q'} ) )
|
| 768 |
{
|
| 769 |
die "you can't have both verbose and quiet, doh!\n";
|
| 770 |
}
|
| 771 |
$VERBOSE = 1 if $OPT{'V'};
|
| 772 |
$OPT{'v'} = 1 if $OPT{'V'};
|
| 773 |
|
| 774 |
# handle really quiet setting
|
| 775 |
if ( $OPT{'Q'} )
|
| 776 |
{
|
| 777 |
# redirect stdout to /dev/null
|
| 778 |
close( STDOUT );
|
| 779 |
open( STDOUT, '>', '/dev/null' )
|
| 780 |
or die( "Can't redirect STDOUT to /dev/null: $!" );
|
| 781 |
}
|
| 782 |
|
| 783 |
# handle -s (subtree check) setting
|
| 784 |
if ( $OPT{s})
|
| 785 |
{
|
| 786 |
verbose "Checking subtree $OPT{s} only\n";
|
| 787 |
}
|
| 788 |
|
| 789 |
if ( $OPT{'m'} and $OPT{'n'} !~ m{^[123]$} )
|
| 790 |
{
|
| 791 |
die "Invalid priority `$OPT{n}'. Please set -n value to 1, 2 or 3.\n"
|
| 792 |
."(assuming you know what you're doing)\n";
|
| 793 |
}
|
| 794 |
|
| 795 |
# load additional module we need for mail
|
| 796 |
if ( $OPT{'m'} )
|
| 797 |
{
|
| 798 |
eval {
|
| 799 |
require MIME::Lite;
|
| 800 |
import MIME::Lite;
|
| 801 |
};
|
| 802 |
die "The module MIME::Lite could not be loaded.\n"
|
| 803 |
."Please install libmime-lite-perl\n" if $@;
|
| 804 |
|
| 805 |
eval {
|
| 806 |
require Email::Address;
|
| 807 |
import Email::Address;
|
| 808 |
};
|
| 809 |
die "The module Email::Address could not be loaded.\n"
|
| 810 |
."Please install libemail-address-perl\n" if $@;
|
| 811 |
}
|
| 812 |
|
| 813 |
if ( $OPT{'g'} and not $OPT{'m'} )
|
| 814 |
{
|
| 815 |
die "Option -g (debuG mail) without -m (use mail) "
|
| 816 |
."really doesn't make much sense\n";
|
| 817 |
}
|
| 818 |
|
| 819 |
# include only files matching $filename
|
| 820 |
my $file_pattern = $OPT{'p'} || $DEFAULT_PATTERN;
|
| 821 |
|
| 822 |
my $translation = shift @ARGV || '';
|
| 823 |
|
| 824 |
# language configuration
|
| 825 |
if ( not $translation )
|
| 826 |
{
|
| 827 |
if ( exists $ENV{DWWW_LANG} )
|
| 828 |
{
|
| 829 |
$translation = $ENV{DWWW_LANG};
|
| 830 |
}
|
| 831 |
elsif ( -e "language.conf" )
|
| 832 |
{
|
| 833 |
open( my $conf, '<', 'language.conf' )
|
| 834 |
or die("Can't read language.conf: $!\n");
|
| 835 |
while (<$conf>)
|
| 836 |
{
|
| 837 |
next if /^#/;
|
| 838 |
chomp;
|
| 839 |
$translation = $_;
|
| 840 |
last;
|
| 841 |
}
|
| 842 |
close $conf;
|
| 843 |
}
|
| 844 |
}
|
| 845 |
|
| 846 |
# Remove slash from the end
|
| 847 |
$translation =~ s{/$}{};
|
| 848 |
|
| 849 |
if ( $translation eq '' )
|
| 850 |
{
|
| 851 |
die "Language not defined in DWWW_LANG, language.conf, "
|
| 852 |
."or on command line\n";
|
| 853 |
}
|
| 854 |
|
| 855 |
return ($translation,$file_pattern,%OPT);
|
| 856 |
}
|
| 857 |
|
| 858 |
#=================================================
|
| 859 |
#== read the translators from translator.db
|
| 860 |
#==
|
| 861 |
sub read_translators
|
| 862 |
{
|
| 863 |
my $lang = shift or die("Internal error: no language specified");
|
| 864 |
my $need_translators = shift;
|
| 865 |
|
| 866 |
my %translators;
|
| 867 |
|
| 868 |
my $db_file = catfile( $lang, 'international', $lang, 'translator.db.pl' );
|
| 869 |
|
| 870 |
verbose "Reading translation database $db_file";
|
| 871 |
|
| 872 |
if ( -e $db_file)
|
| 873 |
{
|
| 874 |
require $db_file;
|
| 875 |
|
| 876 |
verbose "READ TRANSLATOR DB: $db_file\n";
|
| 877 |
|
| 878 |
%translators = %{ init_translators() };
|
| 879 |
|
| 880 |
if ( exists $translators{default} )
|
| 881 |
{
|
| 882 |
my @field_list = keys %{ $translators{default} };
|
| 883 |
foreach my $user (keys %translators)
|
| 884 |
{
|
| 885 |
next if $user eq 'default';
|
| 886 |
foreach my $f (@field_list)
|
| 887 |
{
|
| 888 |
$translators{$user}{$f} = $translators{default}{$f}
|
| 889 |
unless exists $translators{$user}{$f};
|
| 890 |
}
|
| 891 |
}
|
| 892 |
}
|
| 893 |
}
|
| 894 |
|
| 895 |
if ( $need_translators and not %translators )
|
| 896 |
{
|
| 897 |
die "I need my DBs to send mails !\n"
|
| 898 |
."Please read the comments in the script and try again\n";
|
| 899 |
}
|
| 900 |
|
| 901 |
return %translators;
|
| 902 |
}
|
| 903 |
|
| 904 |
#=================================================
|
| 905 |
#== check if a single file is up to date
|
| 906 |
#== returns ($status,$message)
|
| 907 |
#== where status is one of the ST_* constants (see top of file)
|
| 908 |
#==
|
| 909 |
sub check_file
|
| 910 |
{
|
| 911 |
my $file = shift;
|
| 912 |
my $orig = shift;
|
| 913 |
my $lang = shift;
|
| 914 |
my $english_rev = shift; # might be undef
|
| 915 |
my $translation_rev = shift; # might be undef
|
| 916 |
|
| 917 |
die("Internal error: insufficient arguments")
|
| 918 |
unless $file and $orig and $lang;
|
| 919 |
|
| 920 |
# filename of english and translated files
|
| 921 |
my $file_orig = catfile( $orig, $file );
|
| 922 |
my $file_translation = catfile( $lang, $file );
|
| 923 |
|
| 924 |
# revision of the latest change in the english file
|
| 925 |
my $orig_last_change = $english_rev ? $english_rev->{cmt_rev} : 'n/a';
|
| 926 |
|
| 927 |
# revision of the english file that was translated
|
| 928 |
my $transcheck = Webwml::TransCheck->new( $file_translation );
|
| 929 |
my $translation_last_change = $transcheck->revision() || 'n/a';
|
| 930 |
my $translation_translator = $transcheck->maintainer() || undef;
|
| 931 |
my $translation_maxdelta = $transcheck->maxdelta() || undef;
|
| 932 |
|
| 933 |
verbose "Checking $file_translation, $orig revision $orig_last_change";
|
| 934 |
|
| 935 |
# status information
|
| 936 |
my $status = undef;
|
| 937 |
my $str = undef;
|
| 938 |
|
| 939 |
# at this point, there are several possibilities:
|
| 940 |
# 1) file exists both in english and translation
|
| 941 |
# 2) file exists only in english
|
| 942 |
# 3) file exists only in translation
|
| 943 |
# 4) file exists in neither original or translation: can't happen
|
| 944 |
# we handle those cases one by one
|
| 945 |
|
| 946 |
# 1) both files exist
|
| 947 |
if ( -e $file_orig and -e $file_translation )
|
| 948 |
{
|
| 949 |
# now check if both files have correct revisions
|
| 950 |
# again, three cases
|
| 951 |
# 1a) original file doesn't have a revision (can't happen)
|
| 952 |
# 1b) translated file doesn't have a revision (error in wml file)
|
| 953 |
# 1c) revision of both files is known
|
| 954 |
|
| 955 |
# 1a) no revision for english file
|
| 956 |
if ( $orig_last_change eq 'n/a' )
|
| 957 |
{
|
| 958 |
# this can't happen: something must be wrong with this script
|
| 959 |
die( "internal error: no revision for english file" );
|
| 960 |
}
|
| 961 |
|
| 962 |
# 1b) no revision on translated file: error
|
| 963 |
elsif ( $translation_last_change eq 'n/a' )
|
| 964 |
{
|
| 965 |
$status = ST_UNDEFINED;
|
| 966 |
$str = "Unknown status of $file_translation "
|
| 967 |
."(revision should be $orig_last_change)";
|
| 968 |
}
|
| 969 |
|
| 970 |
# 1c) both files have revisions
|
| 971 |
else
|
| 972 |
{
|
| 973 |
# check the revisions to see if they're up to date
|
| 974 |
my $cmp = vcs_cmp_rev( $translation_last_change,
|
| 975 |
$orig_last_change );
|
| 976 |
|
| 977 |
if ( $cmp == 0 ) # revisions equal
|
| 978 |
{
|
| 979 |
# up to date
|
| 980 |
$str = "UpToDate $file_translation";
|
| 981 |
$status = ST_UPTODATE;
|
| 982 |
}
|
| 983 |
elsif ( $cmp == -1 ) # $translation_last_change < $orig_last_change
|
| 984 |
{
|
| 985 |
# out of date
|
| 986 |
$status = ST_NEEDSUPDATE;
|
| 987 |
$str = "NeedToUpdate $file_translation from revision "
|
| 988 |
."$translation_last_change to revision $orig_last_change";
|
| 989 |
}
|
| 990 |
else # $translation_last_change > $orig_last_change
|
| 991 |
{
|
| 992 |
# weirdness: translation is newer than original
|
| 993 |
$status = ST_BROKEN;
|
| 994 |
$str = "Broken revision number r$translation_last_change "
|
| 995 |
."for $file_translation, it should be $orig_last_change";
|
| 996 |
}
|
| 997 |
}
|
| 998 |
}
|
| 999 |
|
| 1000 |
# 2) original file exists, but translation is missing
|
| 1001 |
elsif ( -e $file_orig and not -e $file_translation )
|
| 1002 |
{
|
| 1003 |
$status = ST_MISSING;
|
| 1004 |
$str = "Missing $file_translation version $orig_last_change";
|
| 1005 |
}
|
| 1006 |
|
| 1007 |
# 3) translation exists, but original is missing
|
| 1008 |
elsif ( not -e $file_orig and -e $file_translation )
|
| 1009 |
{
|
| 1010 |
# the translated file doesn't have a translation header,
|
| 1011 |
# so it probably is an original
|
| 1012 |
if ( $translation_last_change eq 'n/a' )
|
| 1013 |
{
|
| 1014 |
$status = ST_NOTATRANSL;
|
| 1015 |
$str = "NotATranslation $file_translation";
|
| 1016 |
}
|
| 1017 |
# otherwise, it has a translation header,
|
| 1018 |
# so the english file was removed
|
| 1019 |
else
|
| 1020 |
{
|
| 1021 |
$status = ST_OBSOLETE;
|
| 1022 |
$str = "Obsolete $file_translation";
|
| 1023 |
}
|
| 1024 |
}
|
| 1025 |
|
| 1026 |
# neither original nor translation exists
|
| 1027 |
else
|
| 1028 |
{
|
| 1029 |
# this should never occur, because it means the function was
|
| 1030 |
# called with an invalid argument
|
| 1031 |
die( "Internal error: file not present in english nor $lang" );
|
| 1032 |
}
|
| 1033 |
|
| 1034 |
# add name of translator
|
| 1035 |
$str .= " (maintainer $translation_translator)" if $translation_translator;
|
| 1036 |
|
| 1037 |
return ($status,$str,$translation_last_change,
|
| 1038 |
$translation_translator,$translation_maxdelta);
|
| 1039 |
}
|
| 1040 |
|
| 1041 |
|
| 1042 |
# get the encoding of a certain file, by looking for wmlrc
|
| 1043 |
sub get_file_charset
|
| 1044 |
{
|
| 1045 |
my $file = shift or croak("No file specified");
|
| 1046 |
|
| 1047 |
# default charset
|
| 1048 |
my $charset = 'utf-8';
|
| 1049 |
|
| 1050 |
# read the wmlrc file
|
| 1051 |
my $wmlrc_dir = dirname($file);
|
| 1052 |
while ( not -e catfile( $wmlrc_dir, '.wmlrc' ) )
|
| 1053 |
{
|
| 1054 |
$wmlrc_dir = dirname $wmlrc_dir;
|
| 1055 |
last if length( $wmlrc_dir ) < 3
|
| 1056 |
}
|
| 1057 |
|
| 1058 |
# now read the wmlrc file to find the charset
|
| 1059 |
my $wmlrc = catfile( $wmlrc_dir,'.wmlrc' );
|
| 1060 |
if ( open( my $fd, '<', $wmlrc ) )
|
| 1061 |
{
|
| 1062 |
while ( my $line = <$fd> )
|
| 1063 |
{
|
| 1064 |
next unless $line =~ m{CHARSET=(.*?)\s*$};
|
| 1065 |
$charset = $1;
|
| 1066 |
last;
|
| 1067 |
}
|
| 1068 |
close($fd);
|
| 1069 |
}
|
| 1070 |
else
|
| 1071 |
{
|
| 1072 |
verbose "wmlrc for `$file' not found; assuming $charset charset";
|
| 1073 |
}
|
| 1074 |
|
| 1075 |
return $charset;
|
| 1076 |
}
|
| 1077 |
|
| 1078 |
# Slurp a file from a particular language in the right encoding
|
| 1079 |
sub read_file_enc
|
| 1080 |
{
|
| 1081 |
my $file = shift or croak("No file specified");
|
| 1082 |
|
| 1083 |
my $charset = get_file_charset( $file );
|
| 1084 |
|
| 1085 |
# now read the file
|
| 1086 |
open( my $fd, '<:bytes', $file ) or return undef;
|
| 1087 |
my $text;
|
| 1088 |
{
|
| 1089 |
local $/ = undef;
|
| 1090 |
$text = <$fd>;
|
| 1091 |
}
|
| 1092 |
close( $fd );
|
| 1093 |
|
| 1094 |
# decode the text
|
| 1095 |
$text = decode( $charset, $text );
|
| 1096 |
|
| 1097 |
return $text;
|
| 1098 |
}
|
| 1099 |
|
| 1100 |
__END__
|
Parent Directory
| 
Revision Log