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

Diff of /webwml/check_trans.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

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

Legend:
Removed from v.1.64  
changed lines
  Added in v.1.65

  ViewVC Help
Powered by ViewVC 1.1.5