dl10n 3.00 / usr / bin / dl10n-pts

#!/usr/bin/perl -w

eval 'exec /usr/bin/perl -w -S $0 ${1+"$@"}'
    if 0; # not running under some shell

# dl10n-pts -- Debian l10n PTS links
#
# Copyright (C) 2009 Nicolas François
#
# Based on dl10n-txt:
# Copyright (C) 2004 Martin Quinson
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#

use strict;
use Getopt::Long; #to parse the args
use Time::gmtime;
use POSIX qw(strftime);

my $progname= $0; $progname= $& if $progname =~ m,[^/]+$,;

my $VERSION = "1.0"; #External Version Number
my $BANNER = "Debian l10n infrastructure -- PTS support v$VERSION"; # Version Banner - text form
my $DB_FILE="./data/status";
my $IGNORE_FILE='';
my $GENDIR="l10n-pkg-status";
my $STATUS_FILE='./data/status.$lang';
my $assume_bts = 0;

use Debian::L10n::Db;

sub syntax_msg {
    my $msg = shift;
    if (defined $msg) {
        print "$progname: $msg\n";
    } else {
        print "$BANNER\n";
    }
    print 
"Syntax: $0 [options]
General options:
    -h, --help                display short help text
    -V, --version             display version and exit

Informations to display:
    -a,--assume-bts           Assume that the content bugs in the BTS were
                                applied.

Database to use:
    --db=DB_FILE              use DB_FILE as database file
                                (instead of $DB_FILE)
    --idb=IGNORE_FILE         use IGNORE_FILE as list of packages to ignore
    --sdb=STATUS_FILE         use STATUS_FILE as status file
                                (instead of $STATUS_FILE)
    --gendir                  Generate the files in this directory
";
    if (defined $msg) {
        exit 1;
    } else {
        exit 0;
    }
}

# Display Version Banner
# Options: -V|--version, --print-version
sub banner {
    if ($_[0] eq 'print-version') {
        print "$VERSION\n";
    } else {
        print "$BANNER\n";
    }
    exit 0;
}

# Hash used to process commandline options
my %opthash = (
# ------------------ general options
        "help|h"        => \&syntax_msg,
        "version|V"     => \&banner,
        "print-version" => \&banner,

# ------------------ configuration options
        "assume-bts|a"  => \$assume_bts,

        "db=s"          => \$DB_FILE,
        "idb=s"         => \$IGNORE_FILE,
        "sdb=s"         => \$STATUS_FILE,

        "gendir=s"      => \$GENDIR,
        );

# init commandline parser
Getopt::Long::config('bundling', 'no_getopt_compat', 'no_auto_abbrev');

# process commandline options
GetOptions(%opthash)
    or syntax_msg("error parsing options");

#-----------------------------------------------------------------------------
#                        The main program                                     
#-----------------------------------------------------------------------------
###
### initialisation
###

my $data = Debian::L10n::Db->new();
$data->read($DB_FILE);

my %ignored_pkgs = ();
if ($IGNORE_FILE) {
    open IGNORE, "$IGNORE_FILE"
        or die "Impossible to read the ignore file $IGNORE_FILE\n";
    while (<IGNORE>) {
        chomp;
        next unless $_;
        $ignored_pkgs{$_} = 1;
    }
    close IGNORE;
}

my @poparts=qw(podebconf po po4a); # Only POs, no template or man

my %score;
my %errors;
my %langs;
foreach my $pkg ($data->list_packages()) {
    next if defined $ignored_pkgs{$pkg};

    foreach my $part (@poparts) {
        my $has_part="has_$part";
        if ($data->$has_part($pkg)) {
            foreach my $line (@{$data->$part($pkg)}){
                my ($pofile, $lang, $stat) = @{$line};
                if (defined $lang and length $lang) {
                    $score{$pkg}{$part}{$lang} =
                        add_stat($stat, $score{$pkg}{$part}{$lang});
                    $langs{$pkg}{$lang} = 1;
                }
            }

            unless (defined $score{$pkg}{$part}{'_'}) {
                # If there is no POT file, try to find the number of strings
                # from the other POs. This is usually a sign for non up to date
                # PO files, so the number of strings in the PO files may vary.
                # I choose to take the greatest number.
                my $t = 0;
                foreach my $lang (keys %{$langs{$pkg}}) {
                    if (    (defined $score{$pkg}{$part}{$lang})
                        and (tot($score{$pkg}{$part}{$lang}) > $t)) {
                        $t = tot($score{$pkg}{$part}{$lang});
                    }
                }
                $score{$pkg}{$part}{'__'} = "0t0f".$t."u";
            } else {
                $score{$pkg}{$part}{'__'} = $score{$pkg}{$part}{'_'};
            }
        }
    }
    if ($data->has_errors($pkg)) {
        foreach my $line (@{$data->errors($pkg)}){
            $errors{$pkg} = "" unless defined $errors{$pkg};
            $errors{$pkg}.=$line
        }
    }
}

my %global_score;
foreach my $pkg (keys %score) {
    foreach my $lang (keys %{$langs{$pkg}}) {
        if ($lang ne "_" and $lang ne "__") {
            foreach my $part (keys %{$score{$pkg}}) {
                next unless defined $score{$pkg}{$part}{$lang};
                if ($part eq "podebconf") {
                    $global_score{$pkg}{debian} =
                        add_stat ($score{$pkg}{$part}{$lang},
                                  $global_score{$pkg}{debian});
                } elsif ($part eq "po") {
                    # FIXME: use heuristics or control field
                    $global_score{$pkg}{nondebian} =
                        add_stat ($score{$pkg}{$part}{$lang},
                                  $global_score{$pkg}{nondebian});
                } elsif ($part eq "po4a") {
                    $global_score{$pkg}{debian} =
                        add_stat ($score{$pkg}{$part}{$lang},
                                  $global_score{$pkg}{debian});
                }
            }
        }
    }
}
open PKGLIST, ">$GENDIR/pkglist"
    or die "Cannot open $GENDIR/pkglist: $!";
print PKGLIST <<EOF;
# <package> <version> (<comma sperated scores>) <link> <todo>
# The scores are:
#   - debian translations: po-debconf and po4a translation
#   - non debian translations: other PO files.
# Scores are currently the percentage of translated strings in the existing PO
# files.
# <todo> indicates if some work is needed on the translations
#
EOF
my $gmt = gmtime;
print PKGLIST "# Generated on: ".(POSIX::strftime "%Y-%m-%d %H:%M:%S", @$gmt)." UTC (db: ".$data->get_date().")\n";
foreach my $pkg (sort keys %global_score) {
    my $pkgstatus = pkg_letter($pkg)."/$pkg.html";
    next unless (   (    (defined $global_score{$pkg}{debian})
                     and ($global_score{$pkg}{debian} ne "0t0f0u"))
                 or (    (defined $global_score{$pkg}{nondebian})
                     and ($global_score{$pkg}{nondebian} ne "0t0f0u")));
    my $todo = 0;
    if (defined $errors{$pkg}) {
        $todo = 1;
    }
    unless (-d "$GENDIR/".pkg_letter($pkg)) {
        mkdir "$GENDIR/".pkg_letter($pkg);
    }
    open PKGSTATUS,">$GENDIR/$pkgstatus"
        or die "Cannot open $GENDIR/$pkgstatus: $!";
    print PKGSTATUS <<EOF;
<html>
  <head>
    <title>Translation status of package $pkg</title>
  </head>
  <body>
EOF
    if (defined $errors{$pkg}) {
        print PKGSTATUS <<EOF;
    <h1>Your package's translations have errors</h1>
    <div>
      You can check if a PO file is valid with the following command:
      <pre style="border-style:solid;border-width:1px">

        msgfmt -c -o /dev/null &lt;po file&gt;
      </pre>
    </div>
    <div>
      The following errors were found in $pkg 's PO files:
      <pre style="border-style:solid;border-width:1px">
$errors{$pkg}
      </pre>
    </div>
    <div>
      Please ask the translator (identified by the Last-Translator field
      in the PO file), the language team (identified by the Language-Team
      field) or <a href="mailto:debian-i18n\@debian.org">debian-i18n</a>
      for a fix.
    </div>
EOF
    }
    if (defined $score{$pkg}{"podebconf"}) {
        my $msg = "";
        # Check if there are no up to date languages
        my $uptodate = 0;
        foreach my $lang (keys %{$score{$pkg}{"podebconf"}}) {
            if (    ($score{$pkg}{"podebconf"}{$lang} =~ m/^([0-9]+)t0f0u$/)
                and ($1 ne "0")) {
                $uptodate = 1;
            }
        }
        if (not $uptodate) {
            $todo = 1;
            $msg = <<EOF;
    <div>
      There are no up-to-date PO files in your package.
      You should call for translations before uploading to unstable.
    </div>
EOF
        }
        my $languages = scalar (keys %{$score{$pkg}{"podebconf"}}) - 2;
        if ($languages < 5) {
            # There are at least 5 very active translation teams:
            # es,de,pt,sv,cs
            $todo = 1;
            $msg = <<EOF;
    <div>
      You debconf templates are translated in only $languages languages.
      You should send a call for translations.
    </div>
EOF
        }
        if (length $msg) {
            print PKGSTATUS <<EOF;
    <h1>Call for translation needed for package $pkg</h1>
$msg
    <div>
      You can send a call for translation using the podebconf-report-po
      command (package po-debconf):
      <pre style="border-style:solid;border-width:1px">

        cd &lt;po directory&gt;
        podebconf-report-po --call
      </pre>
    </div>
EOF
        }
    }

    print PKGLIST "$pkg ".
                  $data->version($pkg).
                  " (".
                  output_percent($global_score{$pkg}{debian}).
                  ",".
                  output_percent($global_score{$pkg}{nondebian}).
                  ") ".
                  "http://i18n.debian.net/l10n-pkg-status/$pkgstatus".
                  " ".
                  $todo.
                  "\n";

    print PKGSTATUS <<EOF;
    <h1>Translation status of package $pkg</h1>
    <table>
EOF
    print PKGSTATUS "<tr><th>Language</th>";
    print PKGSTATUS "<th>podebconf</th>"
        if defined $score{$pkg}{"podebconf"};
    print PKGSTATUS "<th>po</th>"
        if defined $score{$pkg}{"po"};
    print PKGSTATUS "<th>po4a</th>"
        if defined $score{$pkg}{"po4a"};
    print PKGSTATUS "</tr>\n";
    foreach my $lang (sort keys %{$langs{$pkg}}) {
        if ($lang ne "_" and $lang ne "__") {
            print PKGSTATUS "      <tr><td align=\"right\">$lang</td>";
            print PKGSTATUS "<td>".graph_stats($score{$pkg}{"podebconf"}{$lang})."</td>"
                if defined $score{$pkg}{"podebconf"};
            print PKGSTATUS "<td>".graph_stats($score{$pkg}{"po"}{$lang})."</td>"
                if defined $score{$pkg}{"po"};
            print PKGSTATUS "<td>".graph_stats($score{$pkg}{"po4a"}{$lang})."</td>"
                if defined $score{$pkg}{"po4a"};
            print PKGSTATUS "</tr>\n";
        }
    }
    my $date = strftime('%a, %d %b %Y %H:%M:%S %z', @$gmt);
    my $db_date = $data->get_date();
    print PKGSTATUS <<EOF;
    </table>
    <p>
      <small>Generated on $date (db: $db_date) by </small>
    </p>
    <p>
      <small>Comments: <a href='mailto:debian-l10n-devel\@lists.alioth.debian.org'>Debian L10N Development Team</a></small>
    </p>
  </body>
</html>
EOF
    close PKGSTATUS
        or die "Cannot close $GENDIR/$pkgstatus: $!";
}
close PKGLIST
    or die "Cannot close $GENDIR/pkglist: $!";

sub pkg_letter {
    my $pkg = shift;
    if ($pkg =~ m/^(lib.)/) {
        return $1;
    }
    
    $pkg =~ s/^(.).*$/$1/;
    return $pkg;
}

sub add_stat {
    my $new=shift;
    my $old=shift;

    return $new unless ($old);
    return $new if ($old eq '---');
    $new =~ /([0-9]*)t([0-9]*)f([0-9]*)u/;
    my ($nt,$nf,$nu) = ($1||0, $2||0, $3||0);
    $old =~ /([0-9]*)t([0-9]*)f([0-9]*)u/;
    my ($ot,$of,$ou) = ($1||0, $2||0, $3||0);
    my $res= ($nt+$ot)."t".($nf+$of)."f".($nu+$ou)."u";
    return $res;
}

my %statusDB;
sub merge_bts_stats {
    my $pkg = shift;
    my $lang = shift;
    my $part = shift;
    my $stats = shift;
    my $ori = shift;

    return $stats unless $assume_bts;

    unless (defined $statusDB{$lang}) {
        my $statusDBname = "$STATUS_FILE";
        $statusDBname =~ s/\$lang/$lang/g;

        return $stats unless ( -f $statusDBname );

        $statusDB{$lang} = Debian::L10n::Db->new();
        $statusDB{$lang}->read($statusDBname,0);
    }

    return $stats unless (   $statusDB{$lang}->has_package($pkg)
                          && $statusDB{$lang}->has_status($pkg));

    my $bts_reported = 0;
    foreach my $statusline (@{$statusDB{$lang}->status($pkg)}) {
        my ($kind,$file,$date,$status_from_db,$translator,$url,$bug_nb) = @{$statusline};
        if ($kind eq $part) {
            if ($status_from_db =~ m/^(bts|done|hold|fix|wontfix)$/i) {
                $bts_reported = 1;
            } else {
                $bts_reported = 0;
                last;
            }
        }
    }

    if ($bts_reported) {
        $ori =~ /([0-9]*)t([0-9]*)f([0-9]*)u/;
        $stats = ($1+$2+$3)."t0f0u";
    }

    return $stats;
}

sub tot {
    my $stats = shift;
    return 0 unless $stats;
    return 0 if $stats eq "---";
    my $t = "0";
    my $f = "0";
    my $u = "0";

    if ($stats =~ /([0-9]+)t/) {  $t=$1;  }
    if ($stats =~ /([0-9]+)f/) {  $f=$1;  }
    if ($stats =~ /([0-9]+)u/) {  $u=$1;  }

    return $t+$f+$u;
}

sub output_percent {
    my $stats=shift||"";
    my $t = "0";
    my $u = "0";
    my $f = "0";
    my $percent;

    if ($stats =~ /([0-9]*)t/) {  $t=$1;  }
    if ($stats =~ /([0-9]*)u/) {  $u=$1;  }
    if ($stats =~ /([0-9]*)f/) {  $f=$1;  }
    $percent = calc_percent($t,$t+$u+$f);
    if ($percent eq "NaN") {
        return '-';
    }
    return "$percent";
}

sub calc_percent{
    my $up=shift;
    my $down=shift;
    my $res;

    if ($down==0) {
        return "NaN";
    }
    $res = $up/$down*100;
    $res =~ s/^([0-9]*)\..*/$1/;
    return $res;
}

sub graph_stats {
    my $stats = shift||"";

    my %s = (
        translated   => 0,
        untranslated => 0,
        fuzzy        => 0);

    if ($stats =~ /([0-9]*)t/) {  $s{translated}=$1;  }
    if ($stats =~ /([0-9]*)u/) {  $s{untranslated}=$1;  }
    if ($stats =~ /([0-9]*)f/) {  $s{fuzzy}=$1;  }

    my $total = scalar ($s{translated} + $s{untranslated} + $s{fuzzy});

    return "" if $total == 0;

    my $graph = "";
    foreach my $type (qw/translated fuzzy untranslated/) {
        my $pcent = scalar ($s{$type} * 100 / $total);
        my $width = scalar ($s{$type} * 100 / $total);
        $graph .= "<img height=\"10\" src=\"../img/$type.png\" ";
        $graph .= "style=\"height: 1em;\" ";
        $graph .= "width=\"$width\" ";
        $graph .= "alt=\"$pcent% $type (".$s{$type}."/$total), \" ";
        $graph .= "title=\"$type: $pcent% (".$s{$type}."/$total)\"/>";
    }

    return $graph;
}