dl10n 3.00 / usr / bin / dl10n-check

#!/usr/bin/perl -w

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

# dl10n-check -- script investigating content of debian package searching for l10n stuff
#
# Copyright (C) 1999-2001,2004 Martin Quinson.
# Copyright (C) 2001-2004 Denis Barbier
#
# 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 File::Find;
use File::Path;
use Getopt::Long;

my $have_Text_Iconv = 1;
eval 'use Text::Iconv';
$have_Text_Iconv = 0 if $@;

use Locale::Language;
use Locale::Country;

use Debian::L10n::Db;
use Debian::L10n::Debconf;

use Debian::Pkg::DebSrc;

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

$ENV{'LC_ALL'} = 'C'; # reset locale definition
$SIG{'INT'} = \&interrupted;
$SIG{'QUIT'} = \&interrupted;
sub interrupted {
        $SIG{$_[0]} = 'DEFAULT';
        print "$progname: Interrupted.\n";
        exit -1;
}


#######################################
#  Global Variables
#######################################
my $VERSION = "3.0"; #External Version Number
my $BANNER = "Debian l10n infrastructure -- package checker v$VERSION"; # Version Banner - text form
my $TMP_DIR = "/tmp/dl10n";
my $DB_FILE = "./data/status";
my $MANDB_FILE = "./data/transmonitorman";
my $FROM_FILE = "";
my $DL10N_ROOT = "./";
my $PO_ROOT = "./material/po";
my $TEMPLATES_ROOT = "./material/templates";
my $MENU_ROOT ="./material/menu";
my $MAN_ROOT = "./material/man";
my $verbose = 0;
my @debug;
my $force = 0; # if true, rescan package even if already in db
my $force_material = 0;# if true, rescan package containing material even if already in db
my $remove_unused = 0;# if true, remove packages not found in Packages file
my $mark_obsolete = 0;# if true, mark files as obsolete instead of removing it
my $careful = 0; # if true, save the db after each package

my @pkg_list;   # were we put the list of packages we are required to test
my @pkg_errors; # were we put the name of packages with which we had an error
my @ftp_list;   # were we put the list of ftp sites we are required to test
my @ftp_errors; # were we put the name of packages with which we had an error

#----------------------------------------------------------------------------
# Process Command Line
#----------------------------------------------------------------------------
#######################################
# Subroutines called by various options
# in the options hash below.  These are
# invoked to process the commandline
# options
#######################################
# Display Command Syntax
# Options: -h|--help
sub syntax_msg {
        my $msg = shift;
        if (defined $msg) {
                print STDERR "$progname: $msg\n";
        } else {
                print STDERR "$BANNER\n";
        }
        print
"Syntax: $0 [action] [options] [--] [package|path to the dist]+
General options:
    -h, --help                display short help text
    -v, --verbose             verbose messages
    -V, --version             display version and exit
    -d, --debug               turn debug messages ON
    --print-version           print unadorned version number and exit
Behaviour options:
    --careful                 save the db file after each package proceeding
    -f, --force               force check even if packages are up-to-date in db
    --force-material          force check for any package containing material
    -u, --remove-unused       remove packages not found in Packages files
    --mark-obsolete           when extracting package data, add a .old suffix
                              instead of deleting old files
Configuration options:
    -F, --files-from=FILE     reads dsc filenames from FILE
    --db=DB_FILE              use DB_FILE as database file
                                (instead of $DB_FILE)
    --mandb=DB_FILE           use DB_FILE as database file for manpages
                                (instead of $MANDB_FILE)
    --tmp=TMP_DIR             use TMP_DIR as temp dir
                                (instead of $TMP_DIR)
                                (warning, the script do 'rm -rf' on this dir!)
    --po=PO_ROOT              where to store the po files
                                (instead of $PO_ROOT)
    --templates=DIR           where to store the debconf templates files
                                (instead of $TEMPLATES_ROOT)
    --menu=DIR                where to store the menu files
                                (instead of $MENU_ROOT)
    --man=DIR                 where to store the man files
                                (instead of $MAN_ROOT)
    --root=ROOTDIR            search the libs in ROOTDIR
                                (instead of $DL10N_ROOT)
";
        if (defined $msg) {
                exit 1;
        } else {
                exit 0;
        }
}

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

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

        "verbose|v" => \$verbose,
        "debug|d" => \@debug,     # Count the -d flags

        # ------------------ behaviour options
        "careful" => \$careful,
        "force|f" => \$force,
        "force-material" => \$force_material,
        "remove-unused|u" => \$remove_unused,

        # ------------------ configuration options
        "files-from=s" => \$FROM_FILE,
        "db=s" => \$DB_FILE,
        "mandb=s" => \$MANDB_FILE,
        "tmp=s" => \$TMP_DIR,
        "root=s" => \$DL10N_ROOT,
        "po=s" => \$PO_ROOT,
        "templates=s" => \$TEMPLATES_ROOT,
        "man=s" => \$MAN_ROOT,
        "menu=s" => \$MENU_ROOT
);

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

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

#-----------------------------------------------------------------------------
#                        The main program
#-----------------------------------------------------------------------------
my %synonym;  # developers can't spell sections and priorities...

###
### Initialization
###
my @args = ();
if ($FROM_FILE ne '') {
        if ($FROM_FILE eq '-') {
                @args = <STDIN>;
        } else {
                open(FROM, "< $FROM_FILE")
                        || die "Unable to read from $FROM_FILE\n";
                @args = <FROM>;
                close(FROM);
        }
}
push (@args, @ARGV) or syntax_msg("Nothing to do !");

push (@INC, $DL10N_ROOT);
init_synonym();

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

my $mandata = Debian::L10n::Db->new();
$mandata->read($MANDB_FILE);

# read args to search package files
foreach my $arg (@args) {
        chomp $arg;
        if (-f $arg) {
                $arg =~ /\.dsc$/
                        || die "bad package file name $arg (not a .dsc file)";
                push @pkg_list, $arg;
        } elsif (-d _) {
                # dir ? let's do a `find -name "*.dsc"` on it!
                open (LIST,"find $arg -name \"*.dsc\" -type f|")
                        || die "Can't run find: $!";
                while (<LIST>) {
                        push @pkg_list, $_;
                }
                close LIST;
        } else {
                die "bad argument $arg (neither a .dsc file nor a directory nor a ftp path)";
        }
}

#
# main loop
#
my $dsc; # the path to the dsc file
my $pkg; # the package name
my $ver; # the package version
my $maint; # maintainer's name
my $deb; # instance of Debian::Pkg::DebSrc
my @errors_pkg; # packages for which we had a problem

if ($remove_unused) {
        foreach $pkg ($data->list_packages()) {
                $data->maintainer($pkg, "");
        }
}

PKG: while ($dsc = shift @pkg_list) {
        ###
        ### read the name and the version
        ###
        $pkg = $ver = $maint = "";
        unless (open (DESC, $dsc)) {
                warn "Can't read file $dsc, skipped\n";
                next PKG;
        }
        {
                local $/ = undef;
                $_ = <DESC>;
                if (m/^Source: (.*)$/m) {
                        $pkg = $1;
                }
                if (m/^Version: (.*)$/m) {
                        $ver = $1;
                }
                if (m/^Maintainer: (.*)$/m) {
                        $maint = $1;
                }
        }
        close DESC;
        if ($pkg eq "") {
                warn "Can't read the package name from the desc file $dsc\n";
                push @errors_pkg, $pkg;
                next PKG;
        } elsif ($ver eq "") {
                warn "Can't read the package version from the desc file $dsc\n";
                push @errors_pkg, $pkg;
                next PKG;
        }

        ###
        ### if the package is already in the data, skip it
        ### (unless force specified)
        if ($data->has_package($pkg)) {
                #   Update Maintainer: field
                $data->maintainer($pkg, $maint);
                my $newer = ($data->version($pkg) ne $ver);
                if ($newer) {
                        $newer = system ("dpkg","--compare-versions", $data->version($pkg), "\>", $ver);
                }
                if ((!$force) && $newer==0 && $data->version($pkg) ne ""
                        && !( $force_material &&
                                ($data->has_nls($pkg) ||
                                 $data->has_po($pkg) ||
                                 $data->has_templates($pkg) ||
                                 $data->has_podebconf($pkg) ||
               ($mandata->has_package($pkg) && $mandata->has_man($pkg))))) {
                        print STDERR "Package $pkg $ver (skipped) because it's already in the database\n"
                                if ($verbose);
                        next PKG;
                } else {
                        #   Erase this entry (it's an older version)
                        $data->clear_pkg($pkg);
                }
        }
        print STDERR "Package $pkg $ver (processing)\n" if $verbose;

        ###
        ### unpack it
        ###
        $deb = parse_tarball($dsc, $pkg, $ver, $maint);
        if ($deb) {
                check_pkg($pkg, $deb);
                $data->write($DB_FILE) if $careful;
        }
}

if ($remove_unused) {
        foreach $pkg ($data->list_packages()) {
                next unless (length($pkg) && $pkg =~ /\S/);
                if ($data->maintainer($pkg) eq "") {
                        print STDERR "Package $pkg ".$data->version($pkg)." removed\n" if $verbose;
                        foreach (($PO_ROOT,$TEMPLATES_ROOT,$MENU_ROOT,$MAN_ROOT)) {
                                File::Path::rmtree($_."/".$data->pooldir($pkg));
                        }
                        $data->clear_pkg($pkg);
                }
        }
}

$data->write($DB_FILE);
# print with which packages we had problems
if (@errors_pkg > 0) {
        print STDERR "Some errors where encountred during the check of this packages\n";
        while ($pkg = shift @errors_pkg) {
                print STDERR "    $pkg\n";
        }
}


##############################################################################
#                           The subs                                         #
##############################################################################

sub store_disk_po {
        my $pkg = shift;
        my $filename = shift;

        my $dirname  = $filename;
        $dirname  =~ s#/+[^/]*$##;
        $filename =~ s#.*/##;
        $filename =~ s#:#\%3a#g;
        return $dirname.'/'.$pkg.'_'.$data->version($pkg).'_'.$filename;
}

sub store_disk_menu {
        my $pkg = shift;
        my $filename = shift;

        $filename =~ s#.*debian/##;
        $filename =~ s#/#_#g;
        $filename =~ s#:#\%3a#g;
        return $pkg.'_'.$data->version($pkg).'_'.$filename;
}

sub store_disk_templates {
        my $pkg = shift;
        my $filename = shift;

        $filename =~ s#/#_#g;
        $filename =~ s#:#\%3a#g;
        return $pkg.'_'.$data->version($pkg).'_'.$filename;
}

sub store_disk_man {
        my $pkg = shift;
        my $filename = shift;

        $filename =~ s#/#_#g;
        $filename =~ s#:#\%3a#g;
        return $pkg.'_'.$data->version($pkg).'_'.$filename;
}

sub store_temp_dir {
        my $pkg = shift;
        return $TMP_DIR.'/'.$pkg;
}

sub store_temp {
        my $pkg = shift;
        my $filename = shift;

        return store_temp_dir($pkg).'/'.$filename;
}

sub store_final_location {
        my $type = shift;

        if ($type eq 'po' || $type eq 'podebconf' || $type eq 'po4a') {
                return $PO_ROOT.'/'.$data->pooldir($pkg).'/'.store_disk_po(@_);
        } elsif ($type eq 'templates') {
                return $TEMPLATES_ROOT.'/'.$data->pooldir($pkg).'/'.store_disk_templates(@_);
        } elsif ($type eq 'menu') {
                return $MENU_ROOT.'/'.$data->pooldir($pkg).'/'.store_disk_menu(@_);
        } elsif ($type eq 'man') {
                return $MAN_ROOT.'/'.$data->pooldir($pkg).'/'.store_disk_man(@_);
        }
}

###
### subs
###
sub parse_tarball {
        my $path    = shift;
        my $pkg     = shift;
        my $patch = '';

        $data->package($pkg, $pkg);
        $data->version($pkg, shift);
        $data->maintainer($pkg, shift);
        $data->upstream($pkg, "debian");
 
        # Debian::Pkg::DebSrc->new() seem to have bad time when no / is in there.
        # A broken basename somewhere? FIXME properly
        $path = "./$path" unless $path =~ m|^/|;
    
        #   Determine how many characters of each files are read and cached
        #   when parsing the tar archive
        #
        #   Files cannot be stored on their definitive location,
        #   since we do not know yet the package section, this
        #   information is read from debian/control.
        #   So they are stored in a temporary area, and moved away
        #   as soon as possible.
        #
        my $match = sub {
                my $file = shift;
                #  Do not consider version control files
                return 0  if $file =~ m#(^|/)\{arch\}/#;
                return 0  if $file =~ m#(^|/)\.arch-ids/#;
                return 0  if $file =~ m#(^|/)CVS/#;
                return 0  if $file =~ m#(^|/).svn/#;

                return -1 if $file eq 'debian/control';
                return -1 if $file eq 'debian/packages';
                return ":".store_temp($pkg, $file)
                        if $file eq 'debian/po/POTFILES.in';
                return ":".store_temp($pkg, $file)
                        if $file =~ m#\.pot?$#;
                return ":".store_temp($pkg, $file)
                        if $file =~ m#^debian/[^/]*menu$#;
                return ":".store_temp($pkg, $file)
                        if $file =~ m#^debian/(.+\/)?(.+[.-])?templates([.-].+)?$#;
                my $manpage = match_manpages($pkg, $file);
                return ":".store_temp($pkg, $file)
                        if $manpage;
                return -1 if $file =~ m#^debian/[^/]*doc-base[^/]*$#;
                return 80  if $file =~ m#(^|/)nls/#;

                return 0;
        };
        my $match_patch = sub {
                my $file = shift;
                return -1 if $file =~ m#^debian/patches/#;
                return -1 if &$match($file);
                return 0;
        };
        my $deb = Debian::Pkg::DebSrc->new($path,
                parse_dft   => $match,
                patch_parse_dft => $match_patch,
                maxmem      => 300000000,
                debug       => scalar @debug,
                patch_debug => 0,
        );
        unless ($deb) {
                $data->clear_pkg($pkg);
                warn "Package $pkg skipped because some file could not be retrieved\n";
                return undef;
        }

        $data->upstream($pkg, "other")
                if $deb->get_diff_name() ne '';
        $data->upstream($pkg, "dbs")
                if $deb->file_matches("^debian/patches/");

        #####[ search the section and priority]#################################
        #
        # (a LOT of packages place spaces here, or upper case, or even typos)
        #
        #####
        my $section  = "";
        my $priority = "";
        my $pooldir  = "main/";
        my $control  = "debian/control";

        unless ($deb->file_exists($control)) {
                #    The debian/ directory may be a link, search for
                #    debian/control elsewhere
                my @list = $deb->file_matches('(^|/)debian/control$');
                if (@list) {
                        $control = $list[0];
                } else {
                        $data->clear_pkg($pkg);
                        warn("Error: can't find debian/control; skipping package $pkg.\n");
                        return undef;
                }
        }
        $_ = $deb->file_content($control);
        if (m/^Section: ([^\n]*)/m) {
                $section = $1;
                $section =~ s/\s//g;
        }
        if (m/^Priority: ([^\n]*)/m) {
                $priority = $1;
                $priority =~ s/\s//g;
        }
        if (defined($synonym{$section})) {
                $section  = $synonym{$section};
                if ($section =~ m#^(contrib|non-free)/#) {
                        $pooldir = $1."/";
                }
        } else {
                $data->add_errors($pkg,"'$section' is not a valid section\n");
                if ($section =~ m#^(contrib|non-free)/#) {
                        $section = $1;
                        $pooldir = $section."/";
                } else {
                        $section  = "unknown";
                }
        }
        if (defined($synonym{$priority})) {
                $priority = $synonym{$priority};
        } else {
                $data->add_errors($pkg,"'$priority' is not a valid priority\n");
                $priority = "unknown";
        }
        if ($pkg =~ m/^(lib.)/) {
                $pooldir .= $1;
        } elsif ($pkg =~ m/^(.)/) {
                $pooldir .= $1;
        }

        $data->section ($pkg, $section);
        $data->priority($pkg, $priority);
        $data->pooldir ($pkg, $pooldir."/".$pkg);

        return $deb;
}

sub check_pkg {
        my $pkg = shift;
        my $deb = shift;

        #####[ Check the type of organization ]#################################
        #
        # try to guess the organisation of this stuff. It could be :
        #   - standard gnu (po dir, Makefile.in.in file and POTFILES.in in it)
        #   - standard nls (nls dir hopefully, with all catalogs in it)
        #   - full         (dir "en" containing po files or "nls" dir or
        #                   "LC_MESSAGES" dir)
        #     (and hopefully man pages and info pages)
        #####
        my $type_org = "";
        my $addtype = sub {
                my $arg = shift;
                if ($type_org eq "") {
                        $type_org = $arg;
                } else {
                        $type_org = "$type_org|$arg";
                }
        };

        &$addtype("nls")  if $deb->file_matches("(?:^|/)nls/");

        &$addtype("gnu")  if $deb->file_matches("(?:^|/)po/Makefile.in.in\$")
                          && $deb->file_matches("(?:^|/)po/POTFILES.in\$");

        &$addtype("full") if $deb->file_matches("(?:^|/)en/.*\\.po\\b")
                          && $deb->file_matches("(?:^|/)en/.*/nls/")
                          && $deb->file_matches("(?:^|/)en/(?:.*/)?LC_MESSAGES/");

        $type_org="?" if ($type_org eq "");
        $data->type($pkg, $type_org);

        search_nls($pkg);
        search_po($pkg);
        search_menu($pkg);
        #   Disable search_docbase at the moment, it overwrites menu files
        #search_docbase($pkg);
        search_podebconf($pkg) || search_templates($pkg);
        search_po4a($pkg);
        search_man($pkg);

        ### Move extracted files to their definitive location
        foreach (($PO_ROOT,$TEMPLATES_ROOT,$MENU_ROOT,$MAN_ROOT)) {
                File::Path::rmtree($_."/".$data->pooldir($pkg))
                        if -d $_."/".$data->pooldir($pkg);
        }
        for my $type (qw(podebconf po4a po templates man menu)) {
                for my $line (@{$data->$type($pkg)}) {
                        my $file = ${$line}[0];
                        $file = ${$line}[3] if $type eq 'man';
                        my $old = store_temp($pkg, $file);
                        my $new = store_final_location($type, $pkg, $file);
                        if ($type eq 'podebconf' && $file !~ m/\.pot?$/) {
                                $new = store_final_location('templates', $pkg, $file);
                        }
                        my $dir = $new;
                        $dir =~ s,/[^/]*$,,;
                        File::Path::mkpath($dir, 0, 0755) unless -d $dir;
                        if (system("gzip -9f -c \"$old\" > \"$new.gz\"")) {
                                unlink "$new.gz";
                                warn "Cannot run: gzip -9f -c \"$old\" > \"$new.gz\": $!\n";
                        }
                }
        }
        File::Path::rmtree(store_temp_dir($pkg));
}

sub match_manpages {
        my $pkg = shift;
        my $file = shift;

        return unless $mandata->has_package($pkg) && $mandata->has_man($pkg);
        foreach my $line (@{$mandata->man($pkg)}) {
                my ($man, $lang, $link) = @{$line};
                return $link if defined($link) && $file eq $link;
        }
        return 0;
}

#----[ search_nls ]-------------------------------------------------------------
sub search_nls {
        my $pkg = shift;
        my $line;

        $data->nls($pkg, ());
        foreach ($deb->file_matches("(?:^|/)nls/")) {
                $line = $deb->file_content($_, 80);
                $data->add_nls($pkg, $_) if $line =~ m/^\$set[\s\d]+#/s;
        }

}

#----[ search_po ]--------------------------------------------------------------
sub search_po {
        my $pkg = shift;

        my @pofiles = $deb->file_matches("\\.pot?\$");

        foreach my $file (@pofiles) {
                next if $file =~ m,^debian/po/,;
                next if $file =~ m,(?:^|/)(doc|man|po4a)/(?:.*/)?po/,;
                next if $file =~ m,(?:^|/)po/pod/,; # po4a
                next if $file =~ m,messages.po$,;
                next if $file =~ m,(^|/)tests/,;
                # Those are tests.
                next if (    (   ($pkg eq "po4a")
                              or ($pkg eq "bioperl"))
                         and ($file =~ m/^t\//));
                next if (    ($pkg eq "po4a")
                         and ($file =~ m/^intl\//));

                process_po_file($pkg, $file, 'po');
        }
        print STDERR "MEM: ".$deb->get_max_memory()."\n" if $verbose;
}

sub convert_to_unicode ($$) {
        my $encoding = shift;
        my $string = shift;
        my $qstring = $string;
        #  If conversion fails, non-ASCII characters are replaced by ?
        $qstring =~ s/[\x80-\xff]/?/g;
        return $qstring unless $have_Text_Iconv;
        my $converter;
        eval '$converter = Text::Iconv->new($encoding, "UTF-32BE")';
        return $qstring if $@;
        my $result = $converter->convert($string) or return $qstring;
        my $ret = "";
        while($result =~ m/(.)(.)(.)(.)/sg) {
                my $ucs = ord($1)*0x1000000 + ord($2)*0x10000 + ord($3)*0x100 + ord($4);
                $ret .= ($ucs > 0x7e ? "&#$ucs;" : chr($ucs));
        }
        return $ret;
}

sub process_po_file {
        my $pkg = shift;
        my $file = shift;
        my $type = shift;
        $type = 'add_'.$type;

        my $filename; #the po file name to be archived
        my $lang=""; # the identified code language
        my $bad_lang=""; #this could be a language, but this is not a valid language
        my $this_stat = ""; #stats for this file
        my $err_msg =""; # err msg of the statistic external command (ie, msgfmt or debconf-stats)
        my $regexp_for_lang_code = '(([a-zA-Z]{2,3})([-_][a-zA-Z]{2})?(@[^./]*)?)(\.[^./]+)?';

        $filename = store_temp($pkg, $file);

        my $lasttrans = "";
        my $langteam = "";

        $this_stat = "";
        $lang = "";
        $lang = '_' if $file=~ m/\.pot$/;
        if ($lang eq "" && $file=~ m,(?:_|\b)$regexp_for_lang_code\.po$,o) {
                $bad_lang =$1;
                if (is_lang($bad_lang)) {
                        $lang = $bad_lang;
                        $bad_lang = "";
                }
        }
        # The next rule is for kde-i18n and other such packages
        if ($lang eq "" && $file =~ m,(?:^|/)$regexp_for_lang_code/(messages|LC_MESSAGES)/,) {
                $bad_lang = $1;
                if (is_lang($bad_lang)) {
                        $lang = $bad_lang;
                        $bad_lang = "";
                }
        }
        if ($lang eq "" && $file =~ m,po/$regexp_for_lang_code/.*\.po,) {
                $bad_lang = $1;
                if (is_lang($bad_lang)) {
                        $lang = $bad_lang;
                        $bad_lang = "";
                }
        }
        if ($lang ne "") {
                # stats the file
                ($this_stat, $err_msg) = read_stats("msgfmt --statistics -o /dev/null $filename 2>&1 1>/dev/null");
                if ($err_msg ne '') {
                        $err_msg =~ s,\Q$filename\E,$file,g;
                        $data->add_errors($pkg, "gettext: ".$err_msg);
                }
        } else { # no valid lang found
                if ($bad_lang eq "") {
                        $data->add_errors($pkg, "gettext: $file: can't guess language");
                } else {
                        $data->add_errors($pkg, "gettext: $file: $bad_lang not a language code");
                }
        }
        # Add this file to the data
        my $header = '';
        if ($lang ne "_") {
                local $/ = "\n\n";
                open(PO, "< $filename");
                while (<PO>) {
                        if (m/^msgid/m) {
                                $header = $_;
                                last;
                        }
                }
                close(PO);
        }
        if ($header ne '') {
                if ($header =~ m/^"Last-Translator:\s*(.*)\\n"\r?$/m) {
                        $lasttrans = $1 || '';
                        $lasttrans =~ s/!//g;
                        $lasttrans = '' if $lasttrans =~ m/EMAIL\@ADDRESS/;
                }
                if ($header =~ m/^"Language-Team:\s*(.*)\\n"\r?$/m) {
                        $langteam = $1 || '';
                        $langteam =~ s/!//g;
                        $langteam = '' if $langteam =~ m/<LL\@li.org>/;
                }
                if ($header =~ m/^"Content-Type:.*charset=(.*)\\n"\r?$/m) {
                        my $encoding = $1;
                        $lasttrans = convert_to_unicode($encoding, $lasttrans);
                        $langteam = convert_to_unicode($encoding, $langteam);
                }
        }

        # Add this file to the data
        $data->$type($pkg, $file, normalize_lang($lang), $this_stat, store_disk_po($pkg, $file), $lasttrans, $langteam);
}

#----[ search_menu ]-----------------------------------------------------------
sub search_menu {
        my $pkg = shift;
        my $filename;

        my @menufiles = $deb->file_matches("^debian/[^/]*menu\$");
        foreach my $file (@menufiles) {
                # Add this file to the data
                $data->add_menu($pkg, $file, store_disk_menu($pkg, $file));
        }
}

#----[ search_docbase ]---------------------------------------------------------
sub search_docbase {
        my $pkg = shift;
        my ($dirname, $filename);

        my @docbasefiles = $deb->file_matches("^debian/[^/]*doc-base[^/]*\$");

        foreach my $file (@docbasefiles) {
                $_ = $deb->file_content($file);
                next unless m/^Document:\s*(\S*)\s*$/m;
                $filename = 'doc-base-' . $1;
                $dirname  = $file;
                $dirname  =~ s#/+[^/]*$##;
                $filename = $dirname . '/' . $filename;
                $filename =~ s,^.*debian/,,;
                $filename =~ s/:/\%3a/g;
                $filename =~ s,/,_,g;
                File::Path::mkpath($MENU_ROOT."/".$data->pooldir($pkg), 0, 0755);
                unless (open (DOCBASE, "> $MENU_ROOT/".$data->pooldir($pkg)."/$filename")) {
                        warn "Unable to write to $MENU_ROOT/".$data->pooldir($pkg)."/$filename\n";
                        next;
                }
                print DOCBASE;
                close DOCBASE;
                $data->add_menu($pkg, $file, $filename);
        }
}

#----[ search_man ]------------------------------------------------------------
sub search_man {
        my $pkg = shift;

        return unless $mandata->has_package($pkg) && $mandata->has_man($pkg);

        foreach my $line (@{$mandata->man($pkg)}) {
                my ($man, $lang, $link) = @{$line};
                next unless defined($link);
                my $manpage = match_manpages($pkg, $link);
                $data->add_man($pkg, $man, $lang, store_disk_man($pkg, $manpage), $link);
        }
}

#----[ search_templates ]------------------------------------------------------
sub search_templates {
        my $pkg = shift;
        my ($filename, $tmpl, %tmpl_stats, $this_stat, @list, @list2);

        my @debconffiles = $deb->file_matches("^debian/([^/]+\\.)?templates([.-]in)?\$");
#        print "Got ".(scalar @debconffiles)." files: ";
#        map { print $_." " } @debconffiles;
#        print "\n";
        $tmpl = Debian::L10n::Debconf->new();
        foreach my $file (@debconffiles) {
                #   All translations in a single file
                next if $deb->file_matches("^".$file."\\...(_..)?\$");
                next if $file =~ m,(^|/)tests/,;

                # Add this file to data
                $filename = store_disk_templates($pkg, $file);
                my $tempfile = store_temp($pkg, $file);

                #  Trap warnings from Debian::L10n::Debconf and reword them
                {
                        local $SIG{__WARN__} = sub {
                                my $msg = $_[0];
                                $msg =~ s,^\Q$tempfile\E,debconf: $file,;
                                $data->add_errors($pkg, $msg);
                        };
                        eval { $tmpl->read_compact($tempfile) };
                }
                %tmpl_stats = $tmpl->stats();
                #  Add information about English template
                $data->add_templates($pkg, $file, '_', $tmpl->count().'t0f0u', $filename);
                foreach (keys %tmpl_stats) {
                        $this_stat = $tmpl_stats{$_}->[0].'t'.$tmpl_stats{$_}->[1].'f'.$tmpl_stats{$_}->[2].'u';
                        $data->add_templates($pkg, $file, normalize_lang($_), $this_stat, $filename);
                }
                {
                        #  Reports an error if debian/po/templates.pot
                        #  or debian/po/POTFILES.in files are missing
                        #  when templates file seem to be in po-debconf
                        #  format.
                        local $/ = undef;
                        open(TEMPLATE, "< $tempfile");
                        $_ = <TEMPLATE>;
                        close(TEMPLATE);
                        if (m/^_/m) {
                                $data->add_errors($pkg, 'podebconf: file debian/po/templates.pot not found') unless $deb->file_exists("debian/po/templates.pot");
                                $data->add_errors($pkg, 'podebconf: file debian/po/POTFILES.in not found') unless $deb->file_exists("debian/po/POTFILES.in");
                        }
                }
        }
        foreach my $file (@debconffiles) {
                #   Translations are put in separate files
                @list = $deb->file_matches("^".$file."\\.");
                next unless @list;
                next if $file =~ m,(^|/)tests/,;

                $filename = store_disk_templates($pkg, $file);

                @list2 = ();
                my %storedfile = ();
                my %origfile = ();
                foreach (@list) {
                        my $relfile = store_temp($pkg, $_);
                        $storedfile{$relfile} = store_disk_templates($pkg, $_);
                        $origfile{$relfile} = $_;
                        push (@list2, $relfile);
                }
                my $tempfile = store_temp($pkg, $file);

                #  Trap warnings from Debian::L10n::Debconf and reword them
                {
                        local $SIG{__WARN__} = sub {
                                my $msg = $_[0];
                                $msg =~ s,^\Q$tempfile\E,debconf: $file,;
                                $data->add_errors($pkg, $msg);
                        };
                        eval { $tmpl->read_dispatched($tempfile, @list2) };
                }
                %tmpl_stats = $tmpl->stats();
                #  Add information about English template
                $data->add_templates($pkg, $file, '_', $tmpl->count().'t0f0u', $filename);
                foreach (keys %tmpl_stats) {
                        $this_stat = $tmpl_stats{$_}->[0].'t'.$tmpl_stats{$_}->[1].'f'.$tmpl_stats{$_}->[2].'u';
                        $data->add_templates($pkg, $origfile{$tmpl->filename($_)}, normalize_lang($_), $this_stat, $storedfile{$tmpl->filename($_)}, $filename);
                }
        }
}

#----[ search_podebconf ]-------------------------------------------------------
sub search_podebconf {
        my $pkg = shift;
        my $pkgroot = store_temp_dir($pkg);

        #  Generate files for packages built with yada.  Beurk.
        my $yada = 0;
        if ($deb->file_exists("debian/packages")) {
                my $yada_template = $deb->file_content("debian/packages");
                if ($yada_template =~ m/^Templates:/m) {
                        $yada = 1;
                        $yada_template =~ s/^.*\nTemplates:\s*\n((?: [^\n]*\n)*)\S.*/$1/s;
                        $yada_template =~ s/^ //mg;
                        $yada_template =~ s/\n\.\s*\n/\n\n/g;
                        open(TEMPLATE, "> $pkgroot/debian/templates");
                        print TEMPLATE $yada_template;
                        close(TEMPLATE);
                        File::Path::mkpath("$pkgroot/debian/po", 0, 0755) unless -d "$pkgroot/debian/po";
                        open(POTFILES_IN,"> $pkgroot/debian/po/POTFILES.in");
                        print POTFILES_IN "[type: gettext/rfc822deb] templates";
                        close(POTFILES_IN);
                        $data->add_podebconf($pkg, "debian/templates", '_', '', store_disk_templates($pkg, "debian/templates"));
                        if (!$deb->file_exists("debian/po/templates.pot")) {
                                $data->add_errors($pkg, "podebconf: file debian/po/templates.pot is missing");
                                system ("cd $pkgroot && debconf-updatepo --skip-merge");
                                process_po_file($pkg, "debian/po/templates.pot", 'podebconf') if -r $pkgroot."/debian/po/templates.pot";
                                return 0;
                        }
                }
        }
        my $can_update = 1;
        if (not $yada) {
                return 0 unless $deb->file_exists("debian/po/templates.pot")
                             && $deb->file_exists("debian/po/POTFILES.in");

                #  If all files from POTFILES.in are found, run debconf-updatepo
                @_ = split(/\n/, $deb->file_content("debian/po/POTFILES.in"));
                foreach (@_) {
                        next unless s#^\[type: gettext/rfc822deb]\s+#debian/#;
                        s#^debian/\.\./##;
                        s#\s+$##;
                        if ($deb->file_exists($_)) {
                                $data->add_podebconf($pkg, $_, '_', '', store_disk_templates($pkg, $_));
                        } else {
                                $data->add_errors($pkg, "podebconf: file $_ not found");
                                $can_update = 0;
                        }
                }
        }
        my @pofiles = $deb->file_matches("^debian/po/.*\\.pot?\$");
        if ($can_update) {
                system ("cp $pkgroot/debian/po/templates.pot $pkgroot/debian/po/templates.dl10n.pot");
                system ("cd $pkgroot && debconf-updatepo --skip-merge");
                if (system ("msgcmp --use-untranslated $pkgroot/debian/po/templates.dl10n.pot $pkgroot/debian/po/templates.pot >/dev/null 2>&1 && msgcmp --use-untranslated $pkgroot/debian/po/templates.pot $pkgroot/debian/po/templates.dl10n.pot >/dev/null 2>&1")) {
                        $data->add_errors($pkg, "podebconf: file debian/po/templates.pot not up-to-date");
                }
                unlink "$pkgroot/debian/po/templates.dl10n.pot";
                foreach my $file (@pofiles) {
                        next if $file eq 'debian/po/templates.pot';
                        if (system ("msgcmp --use-untranslated --use-fuzzy $pkgroot/$file $pkgroot/debian/po/templates.pot >/dev/null 2>&1 && msgcmp --use-fuzzy --use-untranslated $pkgroot/debian/po/templates.pot $pkgroot/$file >/dev/null 2>&1")) {
                                $data->add_errors($pkg, "podebconf: file $file not up-to-date");
                        }
                }
                #  Update PO files
                my $debconf_updatepo_out = qx"cd $pkgroot && debconf-updatepo --skip-pot 2>&1";
                if (    defined $debconf_updatepo_out
                    and length $debconf_updatepo_out) {
                    warn "Package $pkg, debconf-updatepo returned:\n$debconf_updatepo_out\n";
                }
        }

        foreach my $file (@pofiles) {
                process_po_file($pkg, $file, 'podebconf');
        }

        print STDERR "MEM: ".$deb->get_max_memory()."\n" if $verbose;
        1;
}

#----[ search_po4a ]-------------------------------------------------------
sub search_po4a {
        my $pkg = shift;

        my @pofiles = ($deb->file_matches("(?:^|/)(doc|man|po4a|pod)/(?:.*/)?po/.*\\.pot?\$"),
                       $deb->file_matches("(?:^|/)po/pod/.*\\.pot?\$"));

        foreach my $file (@pofiles) {
                process_po_file($pkg, $file, 'po4a');
        }

        print STDERR "MEM: ".$deb->get_max_memory()."\n" if $verbose;
        1;
}

#----[ normalize_lang ]--------------------------------------------------------
sub normalize_lang {
        my $lang = shift;
        $lang =~ s/\..*$//;
        if ($lang =~ m,^(..)[-_](..)$,) {
                return lc($1).'_'.uc($2);
        } elsif ($lang =~ m,^(..)$,) {
                return lc($1);
        }
        return $lang;
}

#----[ parse_stats ]------------------------------------------------------------
# transform "5 translated templates, 1 fuzzy translations" -> "5t1f0u"
sub parse_stats {
        my $line = shift;
        my $returned_stats = "";

        $returned_stats .= ($line =~ /(\d+) translated/   ? $1 : "0")."t";
        $returned_stats .= ($line =~ /(\d+) fuzzy/        ? $1 : "0")."f";
        $returned_stats .= ($line =~ /(\d+) untranslated/ ? $1 : "0")."u";

        return $returned_stats;
}

#----[ read_stats ]-------------------------------------------------------------
# run an external command to get the level of translation of a file
# arg1 = cmd to run
#
# ret1 = stats line
# ret2 = "" or error msg got
sub read_stats {
        my $cmd = shift;

        my ($found) = 0;   #true if output seems to be correct
        my $returned_err = "";
        my $returned_stats = "0t0f0u";

        # reads the new stats
        my @lines = qx,$cmd,;
        return ("0t0f0u","Something weird append (no output)\n")
                unless $#lines >= 0;

        foreach (@lines) {
                if (m/translated|fuzzy/) {
                        $returned_stats = parse_stats($_);
                } else {
                        $returned_err .= $_;
                }
        }
        return ($returned_stats,$returned_err);
}

#----[ init_synonym ]-----------------------------------------------------------
# Read the synonyms from the DATA section of this script
sub init_synonym {
        my $right;
        my $wrong;

        while (<DATA>) {
                next unless /\S/;
                next if /^\#/;
                chop;
                if (m/:/) {
                        ($wrong, $right) = split(/:/, $_, 2);
                } else {
                        $wrong = $right = $_;
                }
                $synonym{$wrong} = $right;
        }
        close (DATA);
}

# sub is_lang(code) : returns true iff code is a valide code of language
sub is_lang {
        my $code = shift;
        $code =~ s/\@.*$//;
        #   Accept these codes
        return 1 if $code eq 'du-NL' || $code eq 'no_NY' || $code eq 'cz' || $code eq 'dk' || $code eq 'sp' || $code eq 'wa';
        if ($code =~ /^(..)[-_](..)$/) {
                return (defined(code2language($1)) && defined(code2country($2)));
        }
        return defined code2language($code);
}

1;

__DATA__
# The developers can't spell ! Even the sections and priorities.
# So, this is a list of synonyms...
# the grammar is :
# "$1:$2" means $1 stands for $2 
# "$1" means $1 is valid

extra
important
opcional:optional
optional
required
standard

debian-installer

admin
base
cli-mono
comm
database
debug
devel
doc
editors
electronics
embedded
fonts
games
gnome
gnu-r
gnustep
graphics
hamradio
haskell
httpd
interpreters
java
kde
kernel
libdevel
libs
lisp
localization
mail
math
misc
net
news
ocaml
oldlibs
otherosfs
perl
php
python
ruby
science
shells
sound
tex
text
utils
vcs
video
virtual
web
x11
xfce
zope

contrib/admin
contrib/base
contrib/cli-mono
contrib/comm
contrib/database
contrib/debug
contrib/devel
contrib/doc
contrib/editors
contrib/electronics
contrib/embedded
contrib/fonts
contrib/games
contrib/gnome
contrib/gnu-r
contrib/gnustep
contrib/graphics
contrib/hamradio
contrib/haskell
contrib/httpd
contrib/interpreters
contrib/java
contrib/kde
contrib/kernel
contrib/libdevel
contrib/libs
contrib/lisp
contrib/localization
contrib/mail
contrib/math
contrib/misc
contrib/net
contrib/news
contrib/ocaml
contrib/oldlibs
contrib/otherosfs
contrib/perl
contrib/php
contrib/python
contrib/ruby
contrib/science
contrib/shells
contrib/sound
contrib/tex
contrib/text
contrib/utils
contrib/vcs
contrib/video
contrib/virtual
contrib/web
contrib/x11
contrib/xfce
contrib/zope

non-free/admin
non-free/base
non-free/cli-mono
non-free/comm
non-free/database
non-free/debug
non-free/devel
non-free/doc
non-free/editors
non-free/electronics
non-free/embedded
non-free/fonts
non-free/games
non-free/gnome
non-free/gnu-r
non-free/gnustep
non-free/graphics
non-free/hamradio
non-free/haskell
non-free/httpd
non-free/interpreters
non-free/java
non-free/kde
non-free/kernel
non-free/libdevel
non-free/libs
non-free/lisp
non-free/localization
non-free/mail
non-free/math
non-free/misc
non-free/net
non-free/news
non-free/ocaml
non-free/oldlibs
non-free/otherosfs
non-free/perl
non-free/php
non-free/python
non-free/ruby
non-free/science
non-free/shells
non-free/sound
non-free/tex
non-free/text
non-free/utils
non-free/vcs
non-free/video
non-free/virtual
non-free/web
non-free/x11
non-free/xfce
non-free/zope