1#! /bin/false
2
3# Copyright (C) 2016-2018 Guido Flohr <guido.flohr@cantanea.com>,
4# all rights reserved.
5
6# This program is free software; you can redistribute it and/or modify it
7# under the terms of the GNU Library General Public License as published
8# by the Free Software Foundation; either version 2, or (at your option)
9# any later version.
10
11# This program is distributed in the hope that it will be useful,
12# but WITHOUT ANY WARRANTY; without even the implied warranty of
13# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
14# Library General Public License for more details.
15
16# You should have received a copy of the GNU Library General Public
17# License along with this program; if not, write to the Free Software
18# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
19# USA.
20
21package Locale::XGettext::TT2;
22$Locale::XGettext::TT2::VERSION = '0.7';
23use strict;
24
25use Locale::TextDomain qw(Template-Plugin-Gettext);
26use Template;
27
28use base qw(Locale::XGettext);
29
30sub versionInformation {
31    return __x('{program} (Template-Plugin-Gettext) {version}
32Copyright (C) {years} Cantanea EOOD (http://www.cantanea.com/).
33License GPLv3+: GNU GPL version 3 or later <http://gnu.org/licenses/gpl.html>
34This is free software: you are free to change and redistribute it.
35There is NO WARRANTY, to the extent permitted by law.
36Written by Guido Flohr (http://www.guido-flohr.net/).
37',
38    program => $0, years => '2016-2018',
39    version => $Locale::XGettext::TT2::VERSION);
40}
41
42sub fileInformation {
43    return __(<<EOF);
44The input files should be templates for the Template::Toolkit
45(http://www.template-toolkit.org/).  The strings are usually marked and
46made translatable with the help of "Template::Plugin::Gettext".  Try the
47command "perldoc Template::Plugin::Gettext" for more information.
48EOF
49}
50
51sub canExtractAll {
52    shift;
53}
54
55sub canKeywords {
56    shift;
57}
58
59sub languageSpecificOptions {
60    return [
61        [
62            'plugin|plug-in:s',
63            'plug_in',
64            '    --plug-in=PLUG-IN, --plugin=PLUG-IN',
65            __"the plug-in name (defaults to 'Gettext'), can be an empty string",
66        ]
67    ];
68}
69
70sub defaultKeywords {
71    return [
72               'gettext:1',
73               'ngettext:1,2',
74               'pgettext:1c,2',
75               'gettextp:1,2c',
76               'npgettext:1c,2,3',
77               'ngettextp:1,2,3c',
78               'xgettext:1',
79               'nxgettext:1,2',
80               'pxgettext:1c,2',
81               'xgettextp:1,2c',
82               'npxgettext:1c,2,3',
83               'nxgettextp:1,2,3c',
84       ];
85}
86
87sub defaultFlags {
88    return [
89               "xgettext:1:perl-brace-format",
90               "nxgettext:1:perl-brace-format",
91               "nxgettext:2:perl-brace-format",
92               "pxgettext:2:perl-brace-format",
93               "xgettextp:1:perl-brace-format",
94               "npxgettext:2:perl-brace-format",
95               "npxgettext:3:perl-brace-format",
96               "nxgettextp:1:perl-brace-format",
97               "nxgettextp:2:perl-brace-format",
98    ];
99}
100
101sub readFile {
102    my ($self, $filename) = @_;
103
104    my %options = (
105        ABSOLUTE => 1,
106        # Needed for reading from POTFILES
107        RELATIVE => 1
108    );
109
110    my $parser = Locale::XGettext::TT2::Parser->new(\%options);
111
112    my $tt = Template->new({
113        %options,
114        PARSER => $parser,
115    });
116
117    my $sink;
118    $parser->{__xgettext} = $self;
119    $parser->{__xgettext_filename} = $filename;
120
121    $tt->process($filename, {}, \$sink) or die $tt->error;
122
123    return $self;
124}
125
126package Locale::XGettext::TT2::Parser;
127$Locale::XGettext::TT2::Parser::VERSION = '0.7';
128use strict;
129
130use Locale::TextDomain qw(Template-Plugin-Gettext);
131
132use base qw(Template::Parser);
133
134sub split_text {
135    my ($self, $text) = @_;
136
137    my $chunks = $self->SUPER::split_text($text) or return;
138
139    my $keywords = $self->{__xgettext}->keywords;
140    my $plug_in = $self->{__xgettext}->option('plug_in');
141    $plug_in = 'Gettext' if !defined $plug_in;
142
143    my $ident;
144    my $lplug_in = length $plug_in;
145    while (my $chunk = shift @$chunks) {
146        if (!ref $chunk) {
147            shift @$chunks;
148            next;
149        }
150
151        my ($text, $lineno, $tokens) = @$chunk;
152
153        next if !ref $tokens;
154
155        if ($lplug_in) {
156            if ('USE' eq $tokens->[0] && 'IDENT' eq $tokens->[2]) {
157                if ($plug_in eq $tokens->[3]
158                    && (4 == @$tokens
159                        || '(' eq $tokens->[4])) {
160                    $ident = $plug_in;
161                } elsif ('ASSIGN' eq $tokens->[4] && 'IDENT' eq $tokens->[6]
162                        && $plug_in eq $tokens->[7]) {
163                    $ident = $tokens->[3];
164                }
165                next;
166            }
167
168            next if !defined $ident;
169        } else {
170            $ident = '';
171        }
172
173        for (my $i = 0; $i < @$tokens; $i += 2) {
174            # FIXME! It would be better to copy $tokens into an array
175            # @tokens because we modify the array reference $tokens.
176            # That implies that we iterate over tokens that do ot exist
177            # and that is an unnecessary risk.
178            if ($lplug_in
179                && 'IDENT' eq $tokens->[$i] && $ident eq $tokens->[$i + 1]
180                && 'DOT' eq $tokens->[$i + 2] && 'IDENT' eq $tokens->[$i + 4]
181                && exists $keywords->{$tokens->[$i + 5]}) {
182                my $keyword = $keywords->{$tokens->[$i + 5]};
183                $self->__extractEntry($text, $lineno, $keyword,
184                                    @$tokens[$i + 6 .. $#$tokens]);
185            } elsif ('FILTER' eq $tokens->[$i]
186                    && 'IDENT' eq $tokens->[$i + 2]
187                    && exists $keywords->{$tokens->[$i + 3]}) {
188                my $keyword = $keywords->{$tokens->[$i + 3]};
189                # Inject the block contents as the first argument.
190                if ($i) {
191                    my $first_arg;
192                    if ($tokens->[$i - 2] eq 'LITERAL') {
193                        $first_arg = $tokens->[$i - 1];
194                    } else {
195                        next;
196                    }
197                    # May have been called without parentheses, see
198                    # https://github.com/gflohr/Template-Plugin-Gettext/issues/4
199                    if (!defined $tokens->[4 + $i]) {
200                        $tokens->[4 + $i] = $tokens->[5 + $i] = '(';
201                        $tokens->[6 + $i] = $tokens->[7 + $i] = ')';
202                        splice @$tokens, 6 + $i, 0, LITERAL => $first_arg;
203                    # Or without parentheses and another filter is immediately
204                    # following or the value gets dereferenced with a dot.
205                    # The latter is kind of nonsense but we support it
206                    # elsewhere as well and it is hard to catch.
207                    } elsif ('FILTER' eq $tokens->[4 + $i]
208                             || 'DOT' eq $tokens->[4 + $i]) {
209                        splice @$tokens, 4 + $i, 0,
210                               '(', '(', LITERAL => $first_arg, ')', ')';
211                    } else {
212                        splice @$tokens, 6 + $i, 0,
213                            LITERAL => $first_arg, COMMA => ',';
214                    }
215                } else {
216                    next if !@$chunks;
217                    my $first_arg;
218                    if (ref $chunks->[0]) {
219                        next if $chunks->[0]->[2] ne 'ITEXT';
220                        $first_arg = $chunks->[0]->[0];
221                    } elsif ('TEXT' eq $chunks->[0]) {
222                        $first_arg = $chunks->[1];
223                    } else {
224                        next;
225                    }
226                    splice @$tokens, 6, 0,
227                        'LITERAL', $first_arg, 'COMMA', ',';
228                }
229                $self->__extractEntry($text, $lineno, $keyword,
230                                    @$tokens[$i + 4 .. $#$tokens]);
231            } elsif (!$lplug_in && 'IDENT' eq $tokens->[$i]
232                     && exists $keywords->{$tokens->[$i + 1]}) {
233                my $keyword = $keywords->{$tokens->[$i + 1]};
234                $self->__extractEntry($text, $lineno, $keyword,
235                                    @$tokens[$i + 2 .. $#$tokens]);
236            }
237        }
238    }
239
240    # Stop processing here, so that for example includes are ignored.
241    return [];
242}
243
244sub __extractEntry {
245    my ($self, $text, $lineno, $keyword, @tokens) = @_;
246
247    my $args = sub {
248        my (@tokens) = @_;
249
250        return if '(' ne $tokens[0];
251
252        splice @tokens, 0, 2;
253
254        my @values;
255        while (@tokens) {
256            if ('LITERAL' eq $tokens[0]) {
257                my $string = substr $tokens[1], 1, -1;
258                $string =~ s/\\([\\'])/$1/gs;
259                push @values, $string;
260                splice @tokens, 0, 2;
261            } elsif ('"' eq $tokens[0]) {
262                if ('TEXT' eq $tokens[2]
263                    && '"' eq $tokens[4]
264                    && ('COMMA' eq $tokens[6]
265                        || ')' eq $tokens[6])) {
266                    push @values, $tokens[3];
267                    splice @tokens, 6;
268                } else {
269                      # String containing interpolated variables.
270                    my $msg = __"Illegal variable interpolation at \"\$\"!";
271                    push @values, \$msg;
272                    while (@tokens) {
273                        last if 'COMMA' eq $tokens[0];
274                        last if ')' eq $tokens[0];
275                        shift @tokens;
276                    }
277                }
278            } elsif ('NUMBER' eq $tokens[0]) {
279                push @values, $tokens[1];
280                splice @tokens, 0, 2;
281            } elsif ('IDENT' eq $tokens[0]) {
282                # We store undef as the value because we cannot use it
283                # anyway.
284                push @values, undef;
285                splice @tokens, 0, 2;
286            } elsif ('(' eq $tokens[0]) {
287                splice @tokens, 0, 2;
288                my $nested = 1;
289                while (@tokens) {
290                    if ('(' eq $tokens[0]) {
291                        ++$nested;
292                        splice @tokens, 0, 2;
293                    } elsif (')' eq $tokens[0]) {
294                        --$nested;
295                        splice @tokens, 0, 2;
296                        if (!$nested) {
297                            push @values, undef;
298                            last;
299                        }
300                    } else {
301                        splice @tokens, 0, 2;
302                    }
303                }
304            } else {
305                return @values;
306            }
307
308            return @values if !@tokens;
309
310            my $next = shift @tokens;
311            if ('COMMA' eq $next) {
312                shift @tokens;
313                next;
314            } elsif ('ASSIGN' eq $next && '=>' eq $tokens[0]) {
315                shift @tokens;
316                next;
317            }
318
319            return @values;
320        }
321
322        return @values;
323    };
324
325    my $min_args = $keyword->singular;
326    my %forms = (msgid => $keyword->singular);
327    if ($keyword->plural) {
328        $min_args = $keyword->plural if $keyword->plural > $min_args;
329        $forms{msgid_plural} = $keyword->plural;
330    }
331
332    if ($keyword->context) {
333        $min_args = $keyword->context if $keyword->context > $min_args;
334        $forms{msgctxt} = $keyword->context;
335    }
336
337    my @args = $args->(@tokens);
338
339    # Do we have enough arguments?
340    return if $min_args > @args;
341
342    my $entry = {
343        keyword => $keyword->{function}
344    };
345    foreach my $prop (keys %forms) {
346        my $argno = $forms{$prop} - 1;
347
348        # We are only interested in literal values.  Whatever is
349        # undefined is not parsable or not valid.
350        return if !defined $args[$argno];
351        if (ref $args[$argno]) {
352            my $filename = $self->{__xgettext_filename};
353            die "$filename:$lineno: ${$args[$argno]}\n" if ref $args[$argno];
354        }
355        $entry->{$prop} = $args[$argno];
356    }
357
358    my $reference = $self->{__xgettext_filename} . ':' . $lineno;
359    $reference =~ s/-[1-9][0-9]*$//;
360    $entry->{reference} = $reference;
361
362    if ($text =~ /^#/) {
363        my $comment = '';
364        my @lines = split /\n/, $text;
365        foreach my $line (@lines) {
366            last if $line !~ s/^[ \t\r\f\013]*#[ \t\r\f\013]?//;
367
368            $comment .= $line . "\n";
369        }
370        $entry->{automatic} = $comment;
371    }
372
373    $self->{__xgettext}->addEntry($entry);
374
375    return $self;
376}
377
3781;
379