/[webwml]/webwml/check_trans.pl
ViewVC logotype

Contents of /webwml/check_trans.pl

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5