File Coverage

blib/lib/Locale/Maketext/Test.pm
Criterion Covered Total %
statement 147 162 90.7
branch 47 68 69.1
condition 12 20 60.0
subroutine 24 24 100.0
pod 2 2 100.0
total 232 276 84.0


line stmt bran cond sub pod time code
1             package Locale::Maketext::Test;
2 6     6   120908 use strict;
  6         10  
  6         130  
3 6     6   18 use warnings;
  6         7  
  6         104  
4              
5 6     6   711 use 5.014;
  6         12  
6 6     6   2985 use utf8;
  6         49  
  6         23  
7              
8 6     6   2547 use Try::Tiny;
  6         12468  
  6         239  
9 6     6   29 use File::Spec;
  6         9  
  6         91  
10 6     6   2730 use Test::MockModule;
  6         19222  
  6         140  
11 6     6   2426 use Locale::Maketext::ManyPluralForms;
  6         71285  
  6         33  
12              
13             # ABSTRACT: Locale::Maketext::Test
14              
15             =encoding UTF-8
16              
17             =head1 NAME
18              
19             Locale::Maketext::Test
20              
21             =cut
22              
23             our $VERSION = '0.05';
24              
25             =head1 SYNOPSIS
26              
27             use Locale::Maketext::Test;
28              
29             my $foo = Locale::Maketext::Test->new(directory => '/tmp/locales'); # it will look for files like id.po, ru.po
30              
31             ### optional parameters
32             # languages => ['en', 'de'] - to test specific languages in directory, else it will pick all po files in directory
33             # ideally these languages should be as per https://en.wikipedia.org/wiki/List_of_ISO_639-1_codes format
34             # debug => 1 - if you want to check warnings add debug flag else it will output errors only
35             # auto => 1 set only when you want to fallback in case a key is missing from lexicons
36              
37             # start test
38             my $response = $foo->testlocales();
39              
40             # no errors or warnings if
41             $response->{status} eq 1;
42              
43             # something is wrong when
44             $response->{status} eq 0;
45              
46             # check for errors and warnings in case status is 0
47             $response->{errors} = {id => [qw(error1 error2)], ru => [qw(error1 error2)]};
48             # warnings are only present when debug is set to 1
49             $response->{warnings} = {id => [qw(warn1 warn2)], ru => [qw(warn1 warn2)]};
50              
51             =head1 DESCRIPTION
52              
53             This reads all message ids from the specified PO files and tries to
54             translate them into the destination language. PO files can be specified either
55             as file name (extension .po) or by providing the language. In the latter case
56             the PO file is found in the directory given by the directory option.
57              
58             =head2 TYPES OF ERRORS FOUND
59              
60             =head3 unknown %func() calls
61              
62             Translations can contain function calls in the form of %func(parameters).
63             These functions must be defined in our code. Sometimes translators try
64             to translate the function name which then calls an undefined function.
65              
66             =head3 incorrect number of %plural() parameters
67              
68             Different languages have different numbers of plural forms.
69             Some, like Malay, don't have any plural forms. Some, like English or French,
70             have just 2 forms, singular and one plural. Others like Arabic or Russian have
71             more forms. Whenever a translator uses the %plural() function, he must specify
72             the correct number of plural forms as parameters.
73              
74             =head3 incorrect usage of %d in %plural() parameters
75              
76             In some languages, like English or German, singular is applicable only to the
77             quantity of 1. That means the German translator could come up for instance
78             with the following valid %plural call:
79              
80             %plural(%5,ein Stein,%d Steine)
81              
82             In other languages, like French or Russian, this would be an error. French uses
83             singular also for 0 quantities. So, if the French translator calls:
84              
85             %plural(%5,une porte,%d portes)
86              
87             and in the actual call the quantity of 0 is passed the output is still "une porte".
88             In Russian the problem is even more critical because singular is used for instance
89             also for the quantity of 121.
90              
91             Thus, this test checks if a) the target language is similar to English in having only
92             2 plural forms, singular and one plural, and in applying singular only to the quantity
93             of 1. If both of these conditions are met %plural calls like the above are allowed.
94             Otherwise, if at least one of the parameters passed to %plural contains a %d,
95             all of the parameters must contain the %d as well.
96              
97             That means the following 2 %plural calls are allowed in Russian:
98              
99             %plural(%3,%d книга,%d книги,%d книг)
100             %3 %plural(%3,книга,книги,книг)
101              
102             while this is forbidden:
103              
104             %plural(%3,одна книга,%d книги,%d книг)
105              
106             =head1 SUBROUTINES/METHODS
107              
108             =head2 debug
109              
110             set this if you need to check warnings along with errors
111              
112             =cut
113              
114 6     6   3175 use Moose;
  6         1760685  
  6         46  
115 6     6   31900 use namespace::autoclean;
  6         32555  
  6         16  
116              
117             has debug => (
118             is => 'ro',
119             isa => 'Bool',
120             default => 0
121             );
122              
123             =head2 directory
124              
125             directory where locales files are located
126              
127             =cut
128              
129             has directory => (
130             is => 'ro',
131             isa => 'Str',
132             required => 1
133             );
134              
135             =head2 languages
136              
137             language array, set this if you want to test specific language only in specified directory
138              
139             =cut
140              
141             has languages => (
142             is => 'rw',
143             isa => 'ArrayRef[Str]',
144             default => sub { [] });
145              
146             =head2 auto
147              
148             flag to fallback when a key is missing from lexicons
149              
150             # if this is not set then maketext will output errors if
151             # translations is marked as fuzzy or is missing
152             # read more about it here https://metacpan.org/pod/Locale::Maketext::Lexicon
153             Locale::Maketext::Lexicon->import({ _auto => 1 })
154              
155             =cut
156              
157             has auto => (
158             is => 'ro',
159             isa => 'Bool',
160             default => 0
161             );
162              
163             has _status => (
164             is => 'rw',
165             isa => 'HashRef',
166             lazy => 1,
167             init_arg => undef,
168             default => sub {
169             {
170             status => 1,
171             errors => {},
172             warnings => {}};
173             });
174              
175             =head2 BUILD
176              
177             =cut
178              
179             sub BUILD {
180 6     6 1 11 my $self = shift;
181              
182 6 100       10 unless (scalar @{$self->languages}) {
  6         208  
183 1         1 my @lang = ();
184 1 50       29 if (opendir my $dh, $self->directory) {
185 1         14 while (readdir $dh) {
186 5 100       18 if (my ($x) = ($_ =~ /^(\w+)\.po$/)) {
187 3         7 push @lang, $x;
188             }
189             }
190 1         3 @lang = sort @lang;
191             }
192 1         27 $self->languages(\@lang);
193             }
194              
195 6         160 return Locale::Maketext::ManyPluralForms->import({
196             '_decode' => 1,
197             '_auto' => $self->auto,
198             '*' => ['Gettext' => File::Spec->rel2abs($self->directory) . '/*.po']});
199             }
200              
201             =head2 testlocales
202              
203             test po files in directory specified
204              
205             =cut
206              
207             sub testlocales {
208 6     6 1 71 my $self = shift;
209              
210 6         9 foreach my $lang (@{$self->languages}) {
  6         157  
211 8         692 my $po = $self->_get_po($lang);
212 7         19 my $lg = $po->{header}->{language};
213 7         1007 my $hnd = Locale::Maketext::ManyPluralForms->get_handle($lg);
214 7         11707 $hnd->plural(1, 'test %d');
215              
216 7         873 my $plural_sub = $hnd->{_plural};
217              
218 7         10 my $nplurals = 2; # default
219 7 50       80 $nplurals = $1 if $po->{header}->{'plural-forms'} =~ /\bnplurals=(\d+);/;
220 7         9 my @plural;
221              
222 7   66     51 for (my ($i, $j) = (0, $nplurals); $i < 10000 && $j > 0; $i++) {
223 13         204 my $pos = $plural_sub->($i);
224 13 50       53 unless (defined $plural[$pos]) {
225 13         14 $plural[$pos] = $i;
226 13         50 $j--;
227             }
228             }
229              
230             # $lang_plural_is_like_english==1 means the language has exactly 2 plural forms
231             # and singular is applied only to the quantity of 1. That means something like
232             # %plural(%d,ein Stern,%d Sterne) is allowed. In French for instance, singular is
233             # also applied to the quantity of 0. In that case the singular form should also
234             # contain a %d sequence.
235 7         14 my $lang_plural_is_like_english = ($nplurals == 2);
236 7 100       15 if ($lang_plural_is_like_english) {
237 4         14 for (my $i = 0; $i <= 100_000; $i++) {
238 400004 100       1417492 next if $i == 1;
239 400000 50       5633122 if ($plural_sub->($i) == 0) {
240 0         0 $lang_plural_is_like_english = 0;
241 0         0 last;
242             }
243             }
244             }
245              
246 7         26 my $ln;
247              
248 7         88 $plural_sub = $hnd->can('plural');
249 7         77 my $mock = Test::MockModule->new(ref($hnd), no_auto => 1);
250             $mock->mock(
251             plural => sub {
252             # The plural call should provide exactly the number of forms required by the language
253 1 50   1   229 push @{$self->_status->{errors}->{$lg}},
  1         25  
254 1         5 $self->_format_message($ln, "\%plural() requires $nplurals parameters for this language (provided: @{[@_ - 2]})")
255             unless @_ == $nplurals + 2;
256              
257             # %plural() can be used like
258             #
259             # %plural(%3,word,words)
260             #
261             # or like
262             #
263             # %plural(%3,%d word,%d words)
264             #
265             # In the first case we are only looking for the correct plural form
266             # providing the actual quantity elsewhere.
267             #
268             # The code below checks that either all parameters of the current call contain %d
269             # or none of them. That means something like %plural(%15,one word,%d words) is an
270             # error as singular is in many languages also applied to other quantities than 1.
271              
272 1         2 my $found_percent_d = 0;
273 1         3 my @no_percent_d;
274 1         3 for (my $i = 2; $i < @_; $i++) {
275 2 50       5 if ($_[$i] =~ /%d/) {
276 2         5 $found_percent_d++;
277             } else {
278             # $i==2 means it's the singular parameter. This one is allowed to not contain
279             # %d if the language is like English
280 0 0 0     0 push @no_percent_d, $i - 1 unless ($i == 2 and $lang_plural_is_like_english);
281             }
282             }
283 1 50       2 if ($found_percent_d) {
284 1 50       3 if (@no_percent_d > 1) {
    50          
285 0         0 my $s = join(', ', @no_percent_d[0 .. $#no_percent_d - 1]) . ' and ' . $no_percent_d[-1];
286 0         0 push @{$self->_status->{errors}->{$lg}}, $self->_format_message($ln, "\%plural() parameters $s miss %d");
  0         0  
287             } elsif (@no_percent_d == 1) {
288 0         0 push @{$self->_status->{errors}->{$lg}}, $self->_format_message($ln, "\%plural() parameter $no_percent_d[0] misses %d");
  0         0  
289             }
290             }
291              
292 1         4 goto $plural_sub;
293 7         329 });
294              
295 7         455 for my $test (@{$po->{ids}}) {
  7         29  
296 21         535 $ln = $test->[3];
297 21         21 my $i = 0;
298 21         19 my $j = 0;
299             my @param = map {
300 29         22 $j++;
301 29 100 100     353 push @{$self->_status->{warnings}->{$lg}}, $self->_format_message($ln, "unused parameter \%$j") if (not defined $_ and $self->debug);
  2         46  
302 29 100 100     96 defined $_ && $_ eq 'text' ? 'text' . $i++ : 1;
303 21         22 } @{$test->[1]};
  21         42  
304             try {
305 21     21   669 local $SIG{__WARN__} = sub { die $_[0] };
  0         0  
306 21         101 $hnd->maketext($test->[0], @param);
307             }
308             catch {
309 6 50   6   1122 if (/Can't locate object method "([^"]+)" via package/) {
310 0         0 push @{$self->_status->{errors}->{$lg}}, $self->_format_message($ln, "Unknown directive \%$1()");
  0         0  
311             } else {
312 6         7 push @{$self->_status->{errors}->{$lg}}, $self->_format_message($ln, "Unexpected error:\n$_");
  6         208  
313             }
314 21         169 };
315             }
316             }
317              
318 5         1964 return $self->_status;
319             }
320              
321             =pod
322              
323             This returns hash with status, errors and warnings
324              
325             {
326             status => 1/0, # 1 is success, 0 failure
327             errors => { id => [error1, error2], ru => [error1, error2] },
328             warnings => { id => [warn1, warn2] }
329             }
330              
331             =cut
332              
333             sub _cstring {
334 49     49   1013 my %map = (
335             'a' => "\007",
336             'b' => "\010",
337             't' => "\011",
338             'n' => "\012",
339             'v' => "\013",
340             'f' => "\014",
341             'r' => "\015",
342             );
343 49         178 return $_[0] =~ s/
344             \\
345             (?:
346             ([0-7]{1,3})
347             |
348             x([0-9a-fA-F]{1,2})
349             |
350             ([\\'"?abfvntr])
351             )
352 84 50 33     386 /$1 ? chr(oct($1)) : $2 ? chr(hex($2)) : ($map{$3} || $3)/regx;
    50          
353             }
354              
355             sub _bstring {
356 21     21   20 my @params;
357 21         141 return $_[0] =~ s!
358             (?> # matches %func(%N,parameters...)
359             %
360             (?<func>\w+)
361             \(
362             %
363             (?<p0>[0-9]+)
364             (?<prest>[^\)]*)
365             \)
366             )
367             |
368             (?> # matches %func(parameters)
369             %
370             (?<simplefunc>\w+)
371             \(
372             (?<simpleparm>[^\)]*)
373             \)
374             )
375             | # matches %N
376             %
377             (?<simple>[0-9]+)
378             | # [, ] and ~ should be escaped as ~[, ~] and ~~
379             (?<esc>[\[\]~])
380             !
381 6 50   6   9085 if ($+{esc}) {
  6 50       1692  
  6         4347  
  17         107  
382 0         0 "~$+{esc}";
383             } elsif ($+{simplefunc}) {
384 0         0 "[$+{simplefunc},$+{simpleparm}]";
385             } else {
386 17 100       81 my $pos = ($+{func} ? $+{p0} : $+{simple}) - 1;
387 17 100 66     1039 $params[$pos] = $+{func} && $+{func} eq 'plural' ? 'plural' : ($params[$pos] // 'text');
      50        
388 17 100       148 $+{func} ? "[$+{func},_$+{p0}$+{prest}]" : "[_$+{simple}]";
389             }
390             !regx, \@params;
391             }
392              
393             {
394             my @stack;
395              
396             sub _nextline {
397 242 100   242   362 return pop @stack if @stack;
398 193         555 return scalar readline $_[0];
399             }
400              
401             sub _unread {
402 49     49   55 push @stack, @_;
403 49         42 return;
404             }
405             }
406              
407             sub _get_trans {
408 28     28   24 my $f = shift;
409              
410 28         36 while (defined(my $l = _nextline($f))) {
411 28 50       96 if ($l =~ /^\s*msgstr\s*"(.*)"/) {
412 28         35 my $line = $1;
413 28         36 while (defined($l = _nextline($f))) {
414 105 100       216 if ($l =~ /^\s*"(.*)"/) {
415 84         136 $line .= $1;
416             } else {
417 21         27 _unread($l);
418 21         34 return _cstring($line);
419             }
420             }
421 7         912 return _cstring($line);
422             }
423             }
424 0         0 return;
425             }
426              
427             sub _get_po {
428 8     8   18 my ($self, $lang, $header_only) = @_;
429              
430 8 50       27 unless ($lang =~ /\.po$/) {
431 8         209 $lang = $self->directory . '/' . $lang . '.po';
432             }
433              
434 8         13 my (%header, @ids, $ln);
435 8         12 my $first = 1;
436              
437 6 100   6   31 open my $f, '<:encoding(UTF-8)', $lang or die "Cannot open $lang: $!\n"; ## no critic (RequireBriefOpen)
  6         7  
  6         38  
  8         255  
438             READ:
439 7         39924 while (defined(my $l = _nextline($f))) {
440 67 100       337 if ($l =~ /^\s*msgid\s*"(.*)"/) {
441 28         42 my $line = $1;
442 28         32 $ln = $.;
443 28         33 while (defined($l = _nextline($f))) {
444 28 50       119 if ($l =~ /^\s*"(.*)"/) {
445 0         0 $line .= $1;
446             } else {
447 28         39 _unread($l);
448 28 100       72 if ($first) {
    50          
449 7         11 undef $first;
450 7         19 %header = map { split /\s*:\s*/, lc($_), 2 } split /\n/, _get_trans($f);
  84         1271  
451 7 50       34 last READ if $header_only;
452             } elsif (length $line) {
453 21         32 push @ids, [_bstring(_cstring($line)), _get_trans($f), $ln];
454             }
455 28         70 last;
456             }
457             }
458             }
459             }
460              
461             return {
462             header => \%header,
463             ids => \@ids,
464             lang => $header{language},
465 7         121 file => $lang,
466             };
467             }
468              
469             sub _format_message {
470 9     9   15 my ($self, $line, $message) = @_;
471 9         208 $self->_status->{status} = 0;
472 9         83 return "(line=$line): $message";
473             }
474              
475             __PACKAGE__->meta->make_immutable;
476              
477             =head1 AUTHOR
478              
479             Binary.com, C<< <binary at cpan.org> >>
480              
481             =head1 BUGS
482              
483             Please report any bugs or feature requests to C<bug-locale-maketext-test at rt.cpan.org>, or through
484             the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Locale-Maketext-Test>. I will be notified, and then you'll
485             automatically be notified of progress on your bug as I make changes.
486              
487              
488              
489              
490             =head1 SUPPORT
491              
492             You can find documentation for this module with the perldoc command.
493              
494             perldoc Locale::Maketext::Test
495              
496              
497             You can also look for information at:
498              
499             =over 4
500              
501             =item * RT: CPAN's request tracker (report bugs here)
502              
503             L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Locale-Maketext-Test>
504              
505             =item * AnnoCPAN: Annotated CPAN documentation
506              
507             L<http://annocpan.org/dist/Locale-Maketext-Test>
508              
509             =item * CPAN Ratings
510              
511             L<http://cpanratings.perl.org/d/Locale-Maketext-Test>
512              
513             =item * Search CPAN
514              
515             L<http://search.cpan.org/dist/Locale-Maketext-Test/>
516              
517             =back
518              
519              
520             =head1 ACKNOWLEDGEMENTS
521              
522              
523             =cut
524              
525             1; # End of Locale::Maketext::Test