Admin Control Panel v2.0

✎ Editing: podebconf-display-po ← Back

#!/usr/bin/perl -w

use strict;
use File::Temp;
use Getopt::Long;

sub usage {
        my $rc = shift;
        print "Usage: podebconf-display-po [-h] [-f frontend] file.po\n";
        exit($rc);
}

my $help = 0;
my $frontend = '';
Getopt::Long::Configure('bundling');
Getopt::Long::GetOptions(
        "h|help" => \$help,
        "f|frontend=s" => \$frontend,
) || usage(1);
usage(0) if $help;
usage(1) if $#ARGV != 0;

sub unescapechar {
        my $char = shift;
        if ($char eq 'n') {
                # Add a space to conform to debconf templates format
                return "\n ";
        } elsif ($char eq 't') {
                return "\t";
        } elsif ($char eq 'r') {
                return "\r";
        } else {
                #  Fallback also works for \\ and \"
                return $char;
        }
}
sub unescapestr {
        my $text = shift;
        my $out = '';
        my $last = 0;
        while ($text =~ m/\G([^\\]*)\\([ntr"\\])/g) {
                $last = pos($text);
                $out .= $1 . unescapechar($2);
        }
        $out .= substr($text, $last);
        return $out;
}
#  Format 1: No "Type:" in comments
#  Format 2: Only one reference per string and file, line numbers
#            match the ones in templates files
#  Format 3: All references are written into PO files; first template
#            is numbered from 1001, 2nd from 2001 etc.
sub guessFormat {
        my $text = shift;
        return 1 unless $text =~ m/^#\. Type:/;
        while ($text =~ s/#:\s*([^:\s]+):(\d+)/#:/) {
                my ($file,$line) = ($1, $2);
                return 2 if $line < 1000;
        }
        return 3;
}

#  1.  Read the PO file and write a fake templates file

my $fields = {};
my $rfc822Format = 0;

#  Recode PO files into UTF-8 to avoid stateful encodings
{
        open(PO, "msgconv -t UTF-8 $ARGV[0] |")
                or die "'msgconv -t UTF-8 $ARGV[0]' failed: $!\n";
        local $/ = "\n\n";
        while (<PO>) {
                next unless m/^msgid/m;
                s/"\n"//g;
                #  Skip header entry
                next if m/^msgid ""$/m;

my $type = '';
                my $field = '';
                m/^msgid "(.*)"/m;
                my $msgid = unescapestr($1);
                m/^msgstr "(.*)"/m;
                my $msgstr = unescapestr($1);
                #  Escape dollar signs to prevent variable substitutions
                $msgid =~ s/\$/\${dollarsign}/g;
                $msgstr =~ s/\$/\${dollarsign}/g;
                $rfc822Format = guessFormat($_) if $rfc822Format == 0;
                while (s/#:\s*([^:\s]+):(\d+)/#:/) {
                        my ($file,$line) = ($1, $2);
                        my $tmp = $_;
                        if ($rfc822Format == 1) {
                                #  Old format
                                1 while ($tmp =~ s/^#\.\s+(.*)//m);
                                $field = $1;
                        } else {
                                #  New format
                                if ($tmp =~ s/^#\. Type:\s*(\S+)\n//) {
                                        $type = lc($1);
                                }
                                #  The entropy-text type is a plugin
                                $type = "text" if $type eq "entropy-text";
                                if ($tmp =~ s/^#\. (\S+)\n//) {
                                        $field = $1;
                                }
                        }
                        $field = ucfirst($field);
                        $fields->{$file} = {} unless defined($fields->{$file});
                        if (defined $fields->{$file}->{$line}) {
                                if ($field eq 'Choices') {
                                        if ($msgstr =~ m/,/) {
                                            warn "The translation of Choices ".
                                                 "should not contain commas. ".
                                                 "Please fix the translation ".
                                                 "of '$msgid'.";
                                        }
                                        $fields->{$file}->{$line}->{msgid} .= ", ".$msgid;
                                        $fields->{$file}->{$line}->{msgstr} .= ", ".$msgstr;
                                } else {
                                        $fields->{$file}->{$line}->{msgid} .= "\n ".($fields->{$file}->{$line}->{msgid} =~ m/\n/ ? ".\n " : '').$msgid;
                                        $fields->{$file}->{$line}->{msgstr} .= "\n ".($fields->{$file}->{$line}->{msgstr} =~ m/\n/ ? ".\n " : '').$msgstr;
                                }
                        } else {
                                $fields->{$file}->{$line} = {
                                        type => $type,
                                        field => $field,
                                        msgid => $msgid,
                                        msgstr => $msgstr,
                                        line => $line,
                                };
                        }
                }
        }
        close(PO);
}

#  Translated fields in the generated templates file will be written
#  with an extension which is suitable for current user's environment.
#  Of course, there will be trouble if there is some encoding mismatch.
my $lang = $ENV{LANGUAGE} || $ENV{LC_ALL} || $ENV{LC_MESSAGES} || $ENV{LANG} || $ARGV[0];
#  For LANGUAGE
$lang =~ s/:.*//;
#  For filename
$lang =~ s{.*/}{};
$lang =~ s/\.po$//;
#  For locale variables.  Charset and modifiers have to be stripped.
$lang =~ s/[.@].*//;

my $count = 0;
my $new = 1;
my $choices = 0;
my @tempfiles = ();
my ($fh, $template) = File::Temp::tempfile()
        or die "Unable to write temporary files";
push (@tempfiles, $template);
$SIG{INT} = sub { unlink (@tempfiles); exit(1); };

my $titles = {};

#  TODO: Refactor this code
if ($rfc822Format < 3) {
        for my $file (keys %$fields) {
                for (sort { $a <=> $b } keys %{$fields->{$file}}) {
                        $titles->{$count} = 1 if ($fields->{$file}->{$_}->{type} =~ m/title/);
                        print $fh "Template: foo/bar$count\n" if $new;
                        if ($fields->{$file}->{$_}->{field} eq 'Description') {
                                print $fh "Type: ".
                                        (length($fields->{$file}->{$_}->{type}) ?
                                         $fields->{$file}->{$_}->{type} :
                                         ($choices ?  "select" : "string"))."\n";
                        } elsif ($fields->{$file}->{$_}->{field} eq 'Choices') {
                                $choices = 1;
                        } elsif ($fields->{$file}->{$_}->{field} eq 'DefaultChoice') {
                                $fields->{$file}->{$_}->{field} = 'Default';
                        }
                        if ($fields->{$file}->{$_}->{field} eq 'Description' && $choices == 0 && $fields->{$file}->{$_}->{type} =~ m/select/)
                        {
                                #   Dummy Choices field, needed to display the
                                #   question.
                                print $fh "Choices: dummy1, dummy2\n";
                        }
                        print $fh "$fields->{$file}->{$_}->{field}: $fields->{$file}->{$_}->{msgid}\n";
                        print $fh "$fields->{$file}->{$_}->{field}-$lang.UTF-8: $fields->{$file}->{$_}->{msgstr}\n";
                        $new = 0;
                        if ($fields->{$file}->{$_}->{field} eq 'Description') {
                                $count++;
                                $new = 1;
                                $choices = 0;
                                print $fh "\n";
                        }
                }
        }
}
else
{
        my $text = "";
        my %last = ();
        for my $file (keys %$fields) {
                my $oldTemplateNr = 0;
                for (sort { $a <=> $b } keys %{$fields->{$file}}) {
                        $titles->{$count} = 1 if ($fields->{$file}->{$_}->{type} =~ m/title/);
                        my $newTemplateNr = sprintf("%d", $_ / 1000);
                        if ($newTemplateNr != $oldTemplateNr) {
                                if ($count > 0) {
                                        printf $fh "\nTemplate: foo/bar%d\n", $count - 1;
                                        print $fh "Type: ".
                                                (length($last{type}) ?  $last{type} :
                                                 ($choices ?  "select" : "string"))."\n";
                                        if ($choices == 0 && $last{type} =~ m/select/)
                                        {
                                                #   Dummy Choices field, needed to display the
                                                #   question.
                                                print $fh "Choices: dummy1, dummy2\n";
                                        }
                                        print $fh "$text\n";
                                }
                                $count++;
                                $choices = 0;
                                $text = "";
                                $oldTemplateNr = $newTemplateNr;
                                %last = %{$fields->{$file}->{$_}};
                        }
                        if ($fields->{$file}->{$_}->{field} eq 'Choices') {
                                $choices = 1;
                        } elsif ($fields->{$file}->{$_}->{field} eq 'DefaultChoice') {
                                $fields->{$file}->{$_}->{field} = 'Default';
                        }
                        # debconf is kind enough to not display a Select question if there
                        # is only one choice, so add a dummy item
                        if ($fields->{$file}->{$_}->{field} eq 'Choices' && $fields->{$file}->{$_}->{type} eq 'select' && $fields->{$file}->{$_}->{msgid} !~ /,/) {
                                $fields->{$file}->{$_}->{msgid} .= ", dummy2";
                                $fields->{$file}->{$_}->{msgstr} .= ", dummy2";
                        }
                        $text .= "$fields->{$file}->{$_}->{field}: $fields->{$file}->{$_}->{msgid}\n";
                        $text .= "$fields->{$file}->{$_}->{field}-$lang.UTF-8: $fields->{$file}->{$_}->{msgstr}\n";
                }
        }
        if ($text ne "") {
                printf $fh "Template: foo/bar%d\n", $count - 1;
                print $fh "Type: ".
                        (length($last{type}) ?  $last{type} :
                         ($choices ?  "select" : "string"))."\n";
                if ($choices == 0 && $last{type} =~ m/select/)
                {
                        #   Dummy Choices field, needed to display the
                        #   question.
                        print $fh "Choices: dummy1, dummy2\n";
                }
                print $fh "$text";
        }
}
close($fh);

#  2.  Load the templates file in debconf DB

use Debconf::Db;
use Debconf::AutoSelect qw(:all);
use Debconf::Config;

my ($dbth, $dbt) = File::Temp::tempfile()
        or die "Unable to write temporary files";
my ($dbch, $dbc) = File::Temp::tempfile()
        or die "Unable to write temporary files";
push (@tempfiles, $dbt, $dbc);

my %hashconfig = (
        driver => "File",
        mode => '0600',
        name => "config",
        backup => 0,
        filename => $dbc
);
my %hashtemplates = (
        driver => "File",
        mode => '0600',
        name => "templates",
        backup => 0,
        filename => $dbt
);

$Debconf::Db::config=Debconf::Db->makedriver(%hashconfig);
$Debconf::Db::templates=Debconf::Db->makedriver(%hashtemplates);
Debconf::Template->load($template, 'display');
Debconf::Db->save;
unlink $template;

# 3.  Display questions

$Debconf::Db::config=Debconf::Db->makedriver(%hashconfig);
$Debconf::Db::templates=Debconf::Db->makedriver(%hashtemplates);
Debconf::Config->frontend($frontend) if length($frontend);
my $dc_frontend=make_frontend();
my $dc_confmodule=make_confmodule();
my $code=127;

my $cnt = 0;
while (1) {
	$_="RESET foo/bar$cnt\n";
	my $ret=$dc_confmodule->process_command($_);
	if ($titles->{$cnt}) {
		$_="SETTITLE foo/bar$cnt\n";
		$ret=$dc_confmodule->process_command($_);
		$cnt++;
		next;
	}
	$_="SUBST foo/bar$cnt dollarsign \$\n";
	$ret=$dc_confmodule->process_command($_);
	$_="INPUT high foo/bar$cnt\n";
	$ret=$dc_confmodule->process_command($_);
	($code, undef)=split(/ /, $ret, 2);
	last if $code ne 0 && $code ne 30;
	$_="GO\n";
	$ret=$dc_confmodule->process_command($_);
	($code, undef)=split(/ /, $ret, 2);
	$cnt++;
}

$dc_frontend->shutdown;
$dc_confmodule->finish;
Debconf::Db->save;
unlink $dbt, $dbc;

Cancel