xgettext.pl

#!/usr/bin/env perl
# -*- indent-tabs-mode: nil; -*-
# vim:ft=perl:et:sw=4

use strict;
use warnings;
use Cwd qw();
use Getopt::Long;
use Pod::Usage;

use constant NUL   => 0;
use constant BEG   => 1;
use constant PAR   => 2;
use constant QUO1  => 3;
use constant QUO2  => 4;
use constant QUO3  => 5;
use constant BEGM  => 6;
use constant PARM  => 7;
use constant QUOM1 => 8;
use constant QUOM2 => 9;
use constant COMM  => 10;

## A hash that will contain the strings to translate and their meta
## informations.
my %file;
## conatins informations if a string is a date string.
my %type_of_entries;
## Contains unique occurences of each string
my %Lexicon;
## All the strings, in the order they were found while parsing the files
my @ordered_strings = ();
## One occurence of each string, in the order they were found while parsing
## the files
my @unique_keys = ();
## A hash used for control when filling @unique_keys
my %unique_keys;

## Retrieving options.
my %opts;
GetOptions(
    \%opts,                 'add-comments|c:s',
    'copyright-holder=s',   'default-domain|d=s',
    'directory|D=s',        'files-from|f=s',
    'help|h',               'keyword|k:s@',
    'msgid-bugs-address=s', "output|o=s",
    'package-name=s',       'package-version=s',
    'version|v',            't=s@',
) or pod2usage(-verbose => 1, -exitval => 1);

$opts{help} and pod2usage(-verbose => 2, -exitval => 0);
if ($opts{version}) {
    print "sympa-6\n";
    exit;
}

# Initiliazing tags with defaults if necessary.
# Defaults stored separately because GetOptions append arguments to defaults.
# Building the string to insert into the regexp that will search strings to
# extract.
my $available_tags = join('|', @{$opts{t} || []}) || 'locdt|loc';

if ($opts{'files-from'}) {
    my $ifh;
    open $ifh, '<', $opts{'files-from'} or die "$opts{'files-from'}: $!\n";
    my @files = grep { /\S/ and !/\A\s*#/ } split /\r\n|\r|\n/,
        do { local $/; <$ifh> };
    my $cwd = Cwd::getcwd();
    if ($opts{directory}) {
        chdir $opts{directory} or die "$opts{directory}: $!\n";
    }
    @ARGV = map { (glob $_) } @files;
    chdir $cwd;
} elsif (not @ARGV) {
    @ARGV = ('-');
}

# Gathering strings in the source files.
# They will finally be stored into %file.

my $cwd = Cwd::getcwd();
if ($opts{directory}) {
    chdir $opts{directory} or die "$opts{directory}: $!\n";
}

foreach my $file (@ARGV) {
    next if $file =~ /\.po.?$/i;    # Don't parse po files

    my $filename = $file;
    printf STDOUT "Processing $file...\n";
    unless (-f $file) {
        print STDERR "Cannot open $file\n";
        next;
    }

    # cpanfile
    if ($file eq 'cpanfile') {
        CPANFile::load();
        next;
    }

    open my $fh, '<', $file or die "$file: $!\n";
    $_ = do { local $/; <$fh> };
    close $fh;
    $filename =~ s!^./!!;
    my $line;

    # Template Toolkit: [%|loc(...)%]...[%END%]
    $line = 1;
    pos($_) = 0;
    while (
        m!\G.*?\[%[-=~+]?\s*\|\s*($available_tags)(.*?)\s*[-=~+]?%\](.*?)\[%[-=~+]?\s*END\s*[-=~+]?%\]!sg
    ) {
        my ($this_tag, $vars, $str) = ($1, $2, $3);
        $line += (() = ($& =~ /\n/g));    # cryptocontext!
        $str =~ s/\\\'/\'/g;
        $vars =~ s/^\s*\(//;
        $vars =~ s/\)\s*$//;

        add_expression(
            {   expression => $str,
                filename   => $filename,
                line       => $line,
                vars       => $vars,
                (($this_tag eq 'locdt') ? (type => 'date') : ())
            }
        );
    }

    # Template Toolkit: [% "..." | loc(...) %]
    $line = 1;
    pos $_ = 0;
    while (
        m{
        \G .*?
        \[ % [-=~+]? \s*
        (?: \' ((?:\\.|[^'\\])*) \' | \" ((?:\\.|[^"\\])*) \" ) \s*
        \| \s*
        ($available_tags)
        (.*?)
        \s* [-=~+]? % \]
    }sgx
    ) {
        my $str      = $1 || $2;
        my $this_tag = $3;
        my $vars     = $4;

        $line += (() = ($& =~ /\n/g));
        $str =~ s{\\(.)}{
            ($1 eq 't') ? "\t" :
            ($1 eq 'n') ? "\n" :
            ($1 eq 'r') ? "\r" :
            $1
        }eg;
        $vars =~ s/^\s*[(](.*?)[)].*/$1/ or $vars = '';

        add_expression(
            {   expression => $str,
                filename   => $filename,
                line       => $line,
                vars       => $vars,
                (($this_tag eq 'locdt') ? (type => 'date') : ())
            }
        );
    }

    # Template Toolkit with ($tag$%|loc%$tag$)...($tag$%END%$tag$) in
    # mhonarc-ressources.tt2 (<=6.2.60; OBSOLETED)
    $line = 1;
    pos($_) = 0;
    while (
        m!\G.*?\(\$tag\$%\s*\|($available_tags)(.*?)\s*%\$tag\$\)(.*?)\(\$tag\$%[-=~+]?\s*END\s*[-=~+]?%\$tag\$\)!sg
    ) {
        my ($this_tag, $vars, $str) = ($1, $2, $3);
        $line += (() = ($& =~ /\n/g));    # cryptocontext!
        $str =~ s/\\\'/\'/g;
        $vars =~ s/^\s*\(//;
        $vars =~ s/\)\s*$//;

        add_expression(
            {   expression => $str,
                filename   => $filename,
                line       => $line,
                vars       => $vars,
                (($this_tag eq 'locdt') ? (type => 'date') : ())
            }
        );
    }

    # Template Toolkit with <%|loc%>...<%END%> in mhonarc_rc.tt2 (6.2.61b.1 or
    # later)
    if ($file eq 'default/mhonarc_rc.tt2') {
        $line = 1;
        pos($_) = 0;
        while (
            m!\G.*?<%\s*\|($available_tags)(.*?)\s*%>(.*?)<%[-=~+]?\s*END\s*[-=~+]?%>!sg
        ) {
            my ($this_tag, $vars, $str) = ($1, $2, $3);
            $line += (() = ($& =~ /\n/g));    # cryptocontext!
            $str =~ s/\\\'/\'/g;
            $vars =~ s/^\s*\(//;
            $vars =~ s/\)\s*$//;

            add_expression(
                {   expression => $str,
                    filename   => $filename,
                    line       => $line,
                    vars       => $vars,
                    (($this_tag eq 'locdt') ? (type => 'date') : ())
                }
            );
        }
    }

    # Sympa variables (gettext_comment, gettext_id and gettext_unit)
    $line = 1;
    pos($_) = 0;
    while (
        /\G.*?(\'?)(gettext_comment|gettext_id|gettext_unit)\1\s*=>\s*\"((\\.|[^\"])+)\"/sg
    ) {
        my $str = $3;
        $line += (() = ($& =~ /\n/g));    # cryptocontext!
        $str =~ s{(\\.)}{eval "\"$1\""}esg;

        add_expression(
            {   expression => $str,
                filename   => $filename,
                line       => $line
            }
        );
    }

    $line = 1;
    pos($_) = 0;
    while (
        /\G.*?(\'?)(gettext_comment|gettext_id|gettext_unit)\1\s*=>\s*\'((\\.|[^\'])+)\'/sg
    ) {
        my $str = $3;
        $line += (() = ($& =~ /\n/g));    # cryptocontext!
        $str =~ s{(\\.)}{eval "'$1'"}esg;

        add_expression(
            {   expression => $str,
                filename   => $filename,
                line       => $line
            }
        );
    }

    # Sympa scenarios variables (title.gettext)
    $line = 1;
    pos($_) = 0;
    while (/\G.*?title[.]gettext\s*([^\n]+)/sg) {
        my $str = $1;
        $line += (() = ($& =~ /\n/g));    # cryptocontext!

        add_expression(
            {   expression => $str,
                filename   => $filename,
                line       => $line
            }
        );
    }

    # Perl source file
    if ($file =~ /[.](pm|pl|fcgi)([.]in)?\z/) {
        my $state = 0;
        my $str;
        my $vars;
        my $type;

        pos($_) = 0;
        my $orig = 1 + (() = ((my $__ = $_) =~ /\n/g));
    PARSER: {
            $_ = substr $_, pos $_ if pos $_;
            my $line = $orig - (() = ((my $__ = $_) =~ /\n/g));
            # maketext or loc or _
            if ($state == NUL
                and m/\b(
                    translate
                  | gettext(?:_strftime|_sprintf)?
                  | maketext
                  | __?
                  | loc
                  | x
                )/cgx
            ) {
                if ($1 eq 'gettext_strftime') {
                    $state = BEGM;
                    $type  = 'date';
                } elsif ($1 eq 'gettext_sprintf') {
                    $state = BEGM;
                    $type  = 'printf';
                } else {
                    $state = BEG;
                    undef $type;
                }
                redo;
            }
            if (($state == BEG or $state == BEGM) and m/^([\s\t\n]*)/cg) {
                redo;
            }
            # begin ()
            if ($state == BEG and m/^([\S\(])/cg) {
                $state = ($1 eq '(') ? PAR : NUL;
                redo;
            }
            if ($state == BEGM and m/^([\(])/cg) {
                $state = PARM;
                redo;
            }

            # begin or end of string
            if ($state == PAR and m/^\s*(\')/cg) {
                $state = QUO1;
                redo;
            }
            if ($state == QUO1 and m/^([^\']+)/cg) {
                $str .= $1;
                redo;
            }
            if ($state == QUO1 and m/^\'/cg) {
                $state = PAR;
                redo;
            }

            if ($state == PAR and m/^\s*\"/cg) {
                $state = QUO2;
                redo;
            }
            if ($state == QUO2 and m/^([^\"]+)/cg) {
                $str .= $1;
                redo;
            }
            if ($state == QUO2 and m/^\"/cg) {
                $state = PAR;
                redo;
            }

            if ($state == PAR and m/^\s*\`/cg) {
                $state = QUO3;
                redo;
            }
            if ($state == QUO3 and m/^([^\`]*)/cg) {
                $str .= $1;
                redo;
            }
            if ($state == QUO3 and m/^\`/cg) {
                $state = PAR;
                redo;
            }

            if ($state == BEGM and m/^(\')/cg) {
                $state = QUOM1;
                redo;
            }
            if ($state == PARM and m/^\s*(\')/cg) {
                $state = QUOM1;
                redo;
            }
            if ($state == QUOM1 and m/^([^\']+)/cg) {
                $str .= $1;
                redo;
            }
            if ($state == QUOM1 and m/^\'/cg) {
                $state = COMM;
                redo;
            }

            if ($state == BEGM and m/^(\")/cg) {
                $state = QUOM2;
                redo;
            }
            if ($state == PARM and m/^\s*(\")/cg) {
                $state = QUOM2;
                redo;
            }
            if ($state == QUOM2 and m/^([^\"]+)/cg) {
                $str .= $1;
                redo;
            }
            if ($state == QUOM2 and m/^\"/cg) {
                $state = COMM;
                redo;
            }

            if ($state == BEGM) {
                $state = NUL;
                redo;
            }

            # end ()
            if (   ($state == PAR and m/^\s*[\)]/cg)
                or ($state == PARM and m/^\s*[\)]/cg)
                or ($state == COMM and m/^\s*,/cg)) {
                $state = NUL;
                $vars =~ s/[\n\r]//g if $vars;

                add_expression(
                    {   expression => $str,
                        filename   => $filename,
                        line       => $line - (() = $str =~ /\n/g),
                        vars       => $vars,
                        ($type ? (type => $type) : ())
                    }
                ) if $str;
                undef $str;
                undef $vars;
                redo;
            }

            # a line of vars
            if ($state == PAR and m/^([^\)]*)/cg) {
                $vars .= $1 . "\n";
                redo;
            }
            if ($state == PARM and m/^([^\)]*)/cg) {
                $vars .= $1 . "\n";
                redo;
            }
        }

        unless ($state == NUL) {
            my $post = $_;
            $post =~ s/\A(\s*.*\n.*\n.*)\n(.|\n)+\z/$1\n.../;
            warn sprintf "Warning: incomplete state just before ---\n%s\n",
                $post;
        }
    }
}

chdir $cwd;

## Transfers all data from %file to %Lexicon, removing duplicates in the
## process.
my $index = 0;
my @ordered_bis;
my %ordered_hash;
foreach my $str (@ordered_strings) {
    my $ostr  = $str;
    my $entry = $file{$str};
    my $lexi  = $Lexicon{$ostr} // '';

    ## Skip meta information (specific to Sympa)
    next if $str =~ /^_\w+\_$/;

    $str =~ s/"/\\"/g;
    $lexi =~ s/\\/\\\\/g;
    $lexi =~ s/"/\\"/g;

    unless ($ordered_hash{$str}) {
        $ordered_bis[$index] = $str;
        $index++;
        $ordered_hash{$str} = 1;
    }
    $Lexicon{$str} ||= '';
    next if $ostr eq $str;

    $Lexicon{$str} ||= $lexi;
    unless ($file{$str}) { $file{$str} = $entry; }
    delete $file{$ostr};
    delete $Lexicon{$ostr};
}
exit unless %Lexicon;

my $output_file =
       $opts{output}
    || ($opts{'default-domain'} and $opts{'default-domain'} . '.pot')
    || "messages.po";

my $out;
my $pot;
if (-r $output_file) {
    open $pot, '+<', $output_file or die "$output_file: $!\n";
    while (<$pot>) {
        if (1 .. /^$/) { $out .= $_; next }
        last;
    }

    1 while chomp $out;

    seek $pot, 0, 0;
    truncate $pot, 0;
} else {
    open $pot, '>', $output_file or die "$output_file: $!\n";
}
select $pot;

print $out ? "$out\n" : (<< '.');
# SOME DESCRIPTIVE TITLE.
# Copyright (C) YEAR THE PACKAGE'S COPYRIGHT HOLDER
# This file is distributed under the same license as the PACKAGE package.
# FIRST AUTHOR <EMAIL@ADDRESS>, YEAR.
#
#, fuzzy
msgid ""
msgstr ""
"Project-Id-Version: PACKAGE VERSION\n"
"Report-Msgid-Bugs-To: \n"
"POT-Creation-Date: 2002-07-16 17:27+0800\n"
"PO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\n"
"Last-Translator: FULL NAME <EMAIL@ADDRESS>\n"
"Language-Team: LANGUAGE <LL@li.org>\n"
"Language: \n"
"MIME-Version: 1.0\n"
"Content-Type: text/plain; charset=CHARSET\n"
"Content-Transfer-Encoding: 8bit\n"
.

foreach my $entry (@ordered_bis) {
    my %f = (map { ("$_->[0]:$_->[1]" => 1) } @{$file{$entry}});
    my $f = join(' ', sort keys %f);
    $f = " $f" if length $f;

    my $nospace = $entry;
    $nospace =~ s/ +$//;

    if (!$Lexicon{$entry} and $Lexicon{$nospace}) {
        $Lexicon{$entry} =
            $Lexicon{$nospace} . (' ' x (length($entry) - length($nospace)));
    }

    my %seen;

    ## Print code/templates references
    print "\n#:$f\n";

    ## Print variables if any
    foreach my $entry (grep { $_->[2] } @{$file{$entry}}) {
        my ($file, $line, $var) = @{$entry};
        $var =~ s/^\s*,\s*//;
        $var =~ s/\s*$//;
        print "#. ($var)\n" unless !length($var) or $seen{$var}++;
    }

    ## If the entry is a date format, add a developper comment to help
    ## translators
    if ($type_of_entries{$entry} and $type_of_entries{$entry} eq 'date') {
        print "#. This entry is a date/time format\n";
        print
            "#. Check the strftime manpage for format details : http://docs.freebsd.org/info/gawk/gawk.info.Time_Functions.html\n";
    } elsif ($type_of_entries{$entry}
        and $type_of_entries{$entry} eq 'printf') {
        print "#. This entry is a sprintf format\n";
        print
            "#. Check the sprintf manpage for format details : http://perldoc.perl.org/functions/sprintf.html\n";
    }

    print "msgid ";
    output($entry);
    print "msgstr ";
    output($Lexicon{$entry});
}

## Add expressions to list of expressions to translate
## parameters : expression, filename, line, vars
sub add_expression {
    my $param = shift;

    @ordered_strings = (@ordered_strings, $param->{expression});
    push @{$file{$param->{expression}}},
        [$param->{filename}, $param->{line}, $param->{vars}];
    $type_of_entries{$param->{expression}} = $param->{type}
        if $param->{type};

}

sub output {
    my $str = shift // '';

    ## Normalize
    $str =~ s/\\n/\n/g;

    if ($str =~ /\n/) {
        print "\"\"\n";

        ## Avoid additional \n entries
        my @lines = split(/\n/, $str, -1);
        my @output_lines;

        ## Move empty lines to previous line as \n
        my $current_line;
        foreach my $i (0 .. $#lines) {
            if ($lines[$i] eq '') {
                if ($#output_lines < 0) {
                    $current_line .= '\n';
                    next;
                } else {
                    $output_lines[$#output_lines] .= '\n';
                    next;
                }
            } else {
                $current_line .= $lines[$i];
            }
            push @output_lines, $current_line;
            $current_line = '';
        }

        ## Add \n unless
        foreach my $i (0 .. $#output_lines) {
            if ($i == $#output_lines) {
                ## No additional \n
                print "\"$output_lines[$i]\"\n";
            } else {
                print "\"$output_lines[$i]\\n\"\n";
            }
        }

    } else {
        print "\"$str\"\n";
    }
}

package CPANFile;

use strict;
use warnings;
use lib qw(.);

my @entries;

sub feature {
    push @entries,
        {
        expression => $_[1],
        filename   => 'cpanfile',
        line       => [caller]->[2],
        };
}
sub on         { $_[1]->() }
sub recommends { }
sub requires   { }

sub load {
    do 'cpanfile';
    die unless @entries;
    foreach my $entry (@entries) {
        main::add_expression($entry);
    }
}

1;
__END__

=encoding utf-8

=head1 NAME

xgettext.pl - Extract gettext strings from Sympa source

=head1 SYNOPSIS

  xgettext.pl [ options ... ] [ inputfile ... ]

=head1 OPTIONS

=over

=item C<--default-domain> I<domain>, C<-d>I<domain>

Specifies domain.
If this option is specified but output file is not specified
(see C<--output>), C<I<domain>.pot> is used.

=item C<--directory> I<path>, C<-D>I<path>

Specifies directory to search input files.

=item C<--files-from> I<path>, C<-f>I<path>

Get list of input files from the file.

=item C<-g>

B<Deprecated>.
Enables GNU gettext interoperability by printing C<#, maketext-format>
before each entry that has C<%> variables.

=item C<--help>, C<-h>

Shows this documentation and exits.

=item C<--output> I<outputfile>, C<-o>I<outputfile>

POT file name to be written or incrementally
updated C<-> means writing to F<STDOUT>.  If neither this option nor
C<--default-domain> option specified,
F<messages.po> is used.

=item C<-t>I<tag1> ...

Specifies which tag(s) must be used to extract Template Toolkit strings.
Default is C<loc> and C<locdt>.
Can be specified multiple times.

=item C<-u>

B<Deprecated>.
Disables conversion from Maketext format to Gettext
format -- i.e. it leaves all brackets alone.  This is useful if you are
also using the Gettext syntax in your program.

=item C<--version>, C<-v>

Prints "C<sympa-6>" and newline, and then exits.

=item C<--add-comments> [ I<tag> ] , C<-c>[ I<tag> ]

=item C<--copyright-holder> I<string>

=item C<--keyword> [ I<word> ], C<-k>[ I<word> ], ...

=item C<--msgid-bugs-address> I<address>

=item C<--package-name> I<name>

=item C<--package-version> I<version>

These options will do nothing.
They are prepared for compatibility to xgettext of GNU gettext.

=back

I<inputfile>... is the files to extract messages from, if C<--files-from>
option is not specified.

=head1 DESCRIPTION

This program extracts translatable strings from given input files, or
STDIN if none are given.

Currently the following formats of input files are supported:

=over

=item Perl source files

Valid localization function names are:
C<gettext>, C<gettext_sprintf> C<gettext_strftime>,
C<maketext>, C<translate>, C<loc> C<x>, C<_> and C<__>.
Hash keys C<gettext_comment>, C<gettext_id> and C<gettext_unit>
are also recognized.

=item Template Toolkit

Texts inside C<[%|loc%]...[%END%]> or C<[%|locdt%]...[%END%]>
are extracted, unless specified otherwise by C<-t> option.

The alternative format C<[%...|loc%]> is also recognized.

=item Scenario sources

Text content of C<title.gettext> line.

=back

=head1 SEE ALSO

L<Sympa::Language>, L<Sympa::Template>.

=head1 HISTORY

This script was initially based on F<xgettext.pl>
by Autrijus Tang E<lt>autrijus@autrijus.orgE<gt>
which was bundled in L<Locale-Maketext-Lexicon>.
Afterward, it has been drastically rewritten to be adopted to Sympa
and original code hardly remains.

Part of changes are as following:

=over

=item [O. Salaun] 12/08/02 :

Also look for gettext() in perl code.
No more escape '\' chars.
Extract gettext_comment, gettext_id and gettext_unit entries from List.pm.
Extract title.gettext entries from scenarios.

=item [D. Verdin] 05/11/2007 :

Strings ordered following the order in which files are read and
the order in which they appear in the files.
Switch to Getopt::Long to allow multiple value parameter.
Added 't' parameter the specifies which tags to explore in TT2.

=back

=cut