Merge branch 'master' of vc.linet-services.de:public/lx-office-erp
[kivitendo-erp.git] / scripts / locales.pl
1 #!/usr/bin/perl
2
3 # -n do not include custom_ scripts
4 # -v verbose mode, shows progress stuff
5
6 # this version of locles processes not only all required .pl files
7 # but also all parse_html_templated files.
8
9 use utf8;
10 use strict;
11
12 use Carp;
13 use Data::Dumper;
14 use English;
15 use File::Slurp qw(slurp);
16 use FileHandle;
17 use Getopt::Long;
18 use IO::Dir;
19 use List::Util qw(first);
20 use POSIX;
21 use Pod::Usage;
22
23 $OUTPUT_AUTOFLUSH = 1;
24
25 my $opt_v  = 0;
26 my $opt_n  = 0;
27 my $opt_c  = 0;
28 my $debug  = 0;
29
30 parse_args();
31
32 my $basedir      = "../..";
33 my $locales_dir  = ".";
34 my $bindir       = "$basedir/bin/mozilla";
35 my @progdirs     = ( "$basedir/SL" );
36 my $dbupdir      = "$basedir/sql/Pg-upgrade";
37 my $dbupdir2     = "$basedir/sql/Pg-upgrade2";
38 my $menufile     = "menu.ini";
39 my $submitsearch = qr/type\s*=\s*[\"\']?submit/i;
40 our $self        = {};
41 our $missing     = {};
42 our @lost        = ();
43
44 my (%referenced_html_files, %locale, %htmllocale, %alllocales, %cached, %submit);
45 my ($ALL_HEADER, $MISSING_HEADER, $LOST_HEADER);
46
47 init();
48
49 sub find_files {
50   my ($top_dir_name) = @_;
51
52   my (@files, $finder);
53
54   $finder = sub {
55     my ($dir_name) = @_;
56
57     tie my %dir_h, 'IO::Dir', $dir_name;
58
59     push @files,   grep { -f } map { "${dir_name}/${_}" }                       keys %dir_h;
60     my @sub_dirs = grep { -d } map { "${dir_name}/${_}" } grep { ! m/^\.\.?$/ } keys %dir_h;
61
62     $finder->($_) for @sub_dirs;
63   };
64
65   $finder->($top_dir_name);
66
67   return @files;
68 }
69
70 sub merge_texts {
71 # overwrite existing entries with the ones from 'missing'
72   $self->{texts}->{$_} = $missing->{$_} for grep { $missing->{$_} } keys %alllocales;
73
74   # try to set missing entries from lost ones
75   my %lost_by_text = map { ($_->{text} => $_->{translation}) } @lost;
76   $self->{texts}->{$_} = $lost_by_text{$_} for grep { !$self->{texts}{$_} } keys %alllocales;
77 }
78
79 my @bindir_files = find_files($bindir);
80 my @progfiles    = map { m:^(.+)/([^/]+)$:; [ $2, $1 ]  } grep { /\.pl$/ && !/_custom/ } @bindir_files;
81 my @customfiles  = grep /_custom/, @bindir_files;
82
83 push @progfiles, map { m:^(.+)/([^/]+)$:; [ $2, $1 ] } grep { /\.pm$/ } map { find_files($_) } @progdirs;
84
85 # put customized files into @customfiles
86 my (@menufiles, %dir_h);
87
88 if ($opt_n) {
89   @customfiles = ();
90   @menufiles   = ($menufile);
91 } else {
92   tie %dir_h, 'IO::Dir', $basedir;
93   @menufiles = map { "$basedir/$_" } grep { /.*?_$menufile$/ } keys %dir_h;
94   unshift @menufiles, "$basedir/$menufile";
95 }
96
97 tie %dir_h, 'IO::Dir', $dbupdir;
98 my @dbplfiles = grep { /\.pl$/ } keys %dir_h;
99
100 tie %dir_h, 'IO::Dir', $dbupdir2;
101 my @dbplfiles2 = grep { /\.pl$/ } keys %dir_h;
102
103 # slurp the translations in
104 if (-f "$locales_dir/all") {
105   require "$locales_dir/all";
106 }
107 if (-f "$locales_dir/missing") {
108   require "$locales_dir/missing" ;
109   unlink "$locales_dir/missing";
110 }
111 if (-f "$locales_dir/lost") {
112   require "$locales_dir/lost";
113   unlink "$locales_dir/lost";
114 }
115
116 my $charset = slurp("$locales_dir/charset") || 'utf-8';
117 chomp $charset;
118
119 my %old_texts = %{ $self->{texts} || {} };
120
121 handle_file(@{ $_ })       for @progfiles;
122 handle_file($_, $dbupdir)  for @dbplfiles;
123 handle_file($_, $dbupdir2) for @dbplfiles2;
124 scanmenu($_)               for @menufiles;
125
126 # merge entries to translate with entries from files 'missing' and 'lost'
127 merge_texts();
128
129 # generate all
130 generate_file(
131   file      => "$locales_dir/all",
132   header    => $ALL_HEADER,
133   data_name => '$self->{texts}',
134   data_sub  => sub { _print_line($_, $self->{texts}{$_}, @_) for sort keys %alllocales },
135 );
136
137   foreach my $text (keys %$missing) {
138     if ($locale{$text} || $htmllocale{$text}) {
139       unless ($self->{texts}{$text}) {
140         $self->{texts}{$text} = $missing->{$text};
141       }
142     }
143   }
144
145
146 # calc and generate missing
147 my @new_missing = grep { !$self->{texts}{$_} } sort keys %alllocales;
148
149 if (@new_missing) {
150   generate_file(
151     file      => "$locales_dir/missing",
152     header    => $MISSING_HEADER,
153     data_name => '$missing',
154     data_sub  => sub { _print_line($_, '', @_) for @new_missing },
155   );
156 }
157
158 # calc and generate lost
159 while (my ($text, $translation) = each %old_texts) {
160   next if ($alllocales{$text});
161   push @lost, { 'text' => $text, 'translation' => $translation };
162 }
163
164 if (scalar @lost) {
165   splice @lost, 0, (scalar @lost - 50) if (scalar @lost > 50);
166   generate_file(
167     file      => "$locales_dir/lost",
168     header    => $LOST_HEADER,
169     delim     => '()',
170     data_name => '@lost',
171     data_sub  => sub {
172       _print_line($_->{text}, $_->{translation}, @_, template => "  { 'text' => %s, 'translation' => %s },\n") for @lost;
173     },
174   );
175 }
176
177 my $trlanguage = slurp("$locales_dir/LANGUAGE");
178 chomp $trlanguage;
179
180 search_unused_htmlfiles() if $opt_c;
181
182 my $count  = scalar keys %alllocales;
183 my $notext = scalar @new_missing;
184 my $per    = sprintf("%.1f", ($count - $notext) / $count * 100);
185 print "\n$trlanguage - ${per}%";
186 print " - $notext/$count missing" if $notext;
187 print "\n";
188
189 exit;
190
191 # eom
192
193 sub init {
194   $ALL_HEADER = <<EOL;
195 # These are all the texts to build the translations files.
196 # The file has the form of 'english text'  => 'foreign text',
197 # you can add the translation in this file or in the 'missing' file
198 # run locales.pl from this directory to rebuild the translation files
199 EOL
200   $MISSING_HEADER = <<EOL;
201 # add the missing texts and run locales.pl to rebuild
202 EOL
203   $LOST_HEADER  = <<EOL;
204 # The last 50 text strings, that have been removed.
205 # This file has been auto-generated by locales.pl. Please don't edit!
206 EOL
207 }
208
209 sub parse_args {
210   my ($help, $man);
211
212   GetOptions(
213     'no-custom-files' => \$opt_n,
214     'check-files'     => \$opt_c,
215     'verbose'         => \$opt_v,
216     'help'            => \$help,
217     'man'             => \$man,
218     'debug'           => \$debug,
219   );
220
221   if ($help) {
222     pod2usage(1);
223     exit 0;
224   }
225
226   if ($man) {
227     pod2usage(-exitstatus => 0, -verbose => 2);
228     exit 0;
229   }
230
231   if (@ARGV) {
232     my $arg = shift @ARGV;
233     my $ok  = 0;
234     foreach my $dir ("../locale/$arg", "locale/$arg", "../$arg", $arg) {
235       next unless -d $dir && -f "$dir/all" && -f "$dir/LANGUAGE";
236       $ok = chdir $dir;
237       last;
238     }
239
240     if (!$ok) {
241       print "The locale directory '$arg' could not be found.\n";
242       exit 1;
243     }
244
245   } elsif (!-f 'all' || !-f 'LANGUAGE') {
246     print "locales.pl was not called from a locale/* subdirectory,\n"
247       .   "and no locale directory name was given.\n";
248     exit 1;
249   }
250 }
251
252 sub handle_file {
253   my ($file, $dir) = @_;
254   print "\n$file" if $opt_v;
255   %locale = ();
256   %submit = ();
257
258   &scanfile("$dir/$file");
259
260   # scan custom_{module}.pl or {login}_{module}.pl files
261   foreach my $customfile (@customfiles) {
262     if ($customfile =~ /_$file/) {
263       if (-f "$dir/$customfile") {
264         &scanfile("$dir/$customfile");
265       }
266     }
267   }
268
269   $file =~ s/\.pl//;
270 }
271
272 sub extract_text_between_parenthesis {
273   my ($fh, $line) = @_;
274   my ($inside_string, $pos, $text, $quote_next) = (undef, 0, "", 0);
275
276   while (1) {
277     if (length($line) <= $pos) {
278       $line = <$fh>;
279       return ($text, "") unless ($line);
280       $pos = 0;
281     }
282
283     my $cur_char = substr($line, $pos, 1);
284
285     if (!$inside_string) {
286       if ((length($line) >= ($pos + 3)) && (substr($line, $pos, 2)) eq "qq") {
287         $inside_string = substr($line, $pos + 2, 1);
288         $pos += 2;
289
290       } elsif ((length($line) >= ($pos + 2)) &&
291                (substr($line, $pos, 1) eq "q")) {
292         $inside_string = substr($line, $pos + 1, 1);
293         $pos++;
294
295       } elsif (($cur_char eq '"') || ($cur_char eq '\'')) {
296         $inside_string = $cur_char;
297
298       } elsif (($cur_char eq ")") || ($cur_char eq ',')) {
299         return ($text, substr($line, $pos + 1));
300       }
301
302     } else {
303       if ($quote_next) {
304         $text .= '\\' unless $cur_char eq "'";
305         $text .= $cur_char;
306         $quote_next = 0;
307
308       } elsif ($cur_char eq '\\') {
309         $quote_next = 1;
310
311       } elsif ($cur_char eq $inside_string) {
312         undef($inside_string);
313
314       } else {
315         $text .= $cur_char;
316
317       }
318     }
319     $pos++;
320   }
321 }
322
323 sub scanfile {
324   my $file = shift;
325   my $dont_include_subs = shift;
326   my $scanned_files = shift;
327
328   # sanitize file
329   $file =~ s=/+=/=g;
330
331   $scanned_files = {} unless ($scanned_files);
332   return if ($scanned_files->{$file});
333   $scanned_files->{$file} = 1;
334
335   if (!defined $cached{$file}) {
336
337     return unless (-f "$file");
338
339     my $fh = new FileHandle;
340     open $fh, "$file" or die "$! : $file";
341
342     my ($is_submit, $line_no, $sub_line_no) = (0, 0, 0);
343
344     while (<$fh>) {
345       last if /^\s*__END__/;
346
347       $line_no++;
348
349       # is this another file
350       if (/require\s+\W.*\.pl/) {
351         my $newfile = $&;
352         $newfile =~ s/require\s+\W//;
353         $newfile =~ s|bin/mozilla||;
354          $cached{$file}{scan}{"$bindir/$newfile"} = 1;
355       } elsif (/use\s+SL::([\w:]*)/) {
356         my $module =  $1;
357         $module    =~ s|::|/|g;
358         $cached{$file}{scannosubs}{"../../SL/${module}.pm"} = 1;
359       }
360
361       # is this a template call?
362       if (/(?:parse_html_template2?|render)\s*\(\s*[\"\']([\w\/]+)\s*[\"\']/) {
363         my $newfile = "$basedir/templates/webpages/$1.html";
364         if (/parse_html_template2/) {
365           print "E: " . strip_base($file) . " is still using 'parse_html_template2' for " . strip_base($newfile) . ".\n";
366         }
367         if (-f $newfile) {
368            $cached{$file}{scanh}{$newfile} = 1;
369           print "." if $opt_v;
370         } elsif ($opt_c) {
371           print "W: missing HTML template: " . strip_base($newfile) . " (referenced from " . strip_base($file) . ")\n";
372         }
373       }
374
375       my $rc = 1;
376
377       while ($rc) {
378         if (/Locale/) {
379           unless (/^use /) {
380             my ($null, $country) = split /,/;
381             $country =~ s/^ +[\"\']//;
382             $country =~ s/[\"\'].*//;
383           }
384         }
385
386         my $postmatch = "";
387
388         # is it a submit button before $locale->
389         if (/$submitsearch/) {
390           $postmatch = "$'";
391           if ($` !~ /locale->text/) {
392             $is_submit   = 1;
393             $sub_line_no = $line_no;
394           }
395         }
396
397         my ($found) = / (?: locale->text | \b t8 ) \b .*? \(/x;
398         $postmatch = "$'";
399
400         if ($found) {
401           my $string;
402           ($string, $_) = extract_text_between_parenthesis($fh, $postmatch);
403           $postmatch = $_;
404
405           # if there is no $ in the string record it
406           unless (($string =~ /\$\D.*/) || ("" eq $string)) {
407
408             # this guarantees one instance of string
409             $cached{$file}{locale}{$string} = 1;
410
411             # this one is for all the locales
412             $cached{$file}{all}{$string} = 1;
413
414             # is it a submit button before $locale->
415             if ($is_submit) {
416               $cached{$file}{submit}{$string} = 1;
417             }
418           }
419         } elsif ($postmatch =~ />/) {
420           $is_submit = 0;
421         }
422
423         # exit loop if there are no more locales on this line
424         ($rc) = ($postmatch =~ /locale->text/);
425
426         if (   ($postmatch =~ />/)
427             || (!$found && ($sub_line_no != $line_no) && />/)) {
428           $is_submit = 0;
429         }
430       }
431     }
432
433     close($fh);
434
435   }
436
437   $alllocales{$_} = 1             for keys %{$cached{$file}{all}};
438   $locale{$_}     = 1             for keys %{$cached{$file}{locale}};
439   $submit{$_}     = 1             for keys %{$cached{$file}{submit}};
440
441   scanfile($_, 0, $scanned_files) for keys %{$cached{$file}{scan}};
442   scanfile($_, 1, $scanned_files) for keys %{$cached{$file}{scannosubs}};
443   scanhtmlfile($_)                for keys %{$cached{$file}{scanh}};
444
445   $referenced_html_files{$_} = 1  for keys %{$cached{$file}{scanh}};
446 }
447
448 sub scanmenu {
449   my $file = shift;
450
451   my $fh = new FileHandle;
452   open $fh, "$file" or die "$! : $file";
453
454   my @a = grep m/^\[/, <$fh>;
455   close($fh);
456
457   # strip []
458   grep { s/(\[|\])//g } @a;
459
460   foreach my $item (@a) {
461     my @b = split /--/, $item;
462     foreach my $string (@b) {
463       chomp $string;
464       $locale{$string}     = 1;
465       $alllocales{$string} = 1;
466     }
467   }
468
469 }
470
471 sub unescape_template_string {
472   my $in =  "$_[0]";
473   $in    =~ s/\\(.)/$1/g;
474   return $in;
475 }
476
477 sub scanhtmlfile {
478   local *IN;
479
480   my $file = shift;
481
482   if (!defined $cached{$file}) {
483     my %plugins = ( 'loaded' => { }, 'needed' => { } );
484
485     open(IN, $file) || die $file;
486
487     my $copying  = 0;
488     my $issubmit = 0;
489     my $text     = "";
490     while (my $line = <IN>) {
491       chomp($line);
492
493       while ($line =~ m/\[\%[^\w]*use[^\w]+(\w+)[^\w]*?\%\]/gi) {
494         $plugins{loaded}->{$1} = 1;
495       }
496
497       while ($line =~ m/\[\%[^\w]*(\w+)\.\w+\(/g) {
498         my $plugin = $1;
499         $plugins{needed}->{$plugin} = 1 if (first { $_ eq $plugin } qw(HTML LxERP JavaScript MultiColumnIterator L));
500       }
501
502       while ($line =~ m/(?:             # Start von Variante 1: LxERP.t8('...'); ohne darumliegende [% ... %]-Tags
503                           (LxERP\.t8)\( #   LxERP.t8(                             ::Parameter $1::
504                           ([\'\"])      #   Anfang des zu übersetzenden Strings   ::Parameter $2::
505                           (.*?)         #   Der zu übersetzende String            ::Parameter $3::
506                           (?<!\\)\2     #   Ende des zu übersetzenden Strings
507                         |               # Start von Variante 2: [% '...' | $T8 %]
508                           \[\%          #   Template-Start-Tag
509                           [\-~#]?       #   Whitespace-Unterdrückung
510                           \s*           #   Optional beliebig viele Whitespace
511                           ([\'\"])      #   Anfang des zu übersetzenden Strings   ::Parameter $4::
512                           (.*?)         #   Der zu übersetzende String            ::Parameter $5::
513                           (?<!\\)\4     #   Ende des zu übersetzenden Strings
514                           \s*\|\s*      #   Pipe-Zeichen mit optionalen Whitespace davor und danach
515                           (\$T8)        #   Filteraufruf                          ::Parameter $6::
516                           .*?           #   Optionale Argumente für den Filter
517                           \s*           #   Whitespaces
518                           [\-~#]?       #   Whitespace-Unterdrückung
519                           \%\]          #   Template-Ende-Tag
520                         )
521                        /ix) {
522         my $module = $1 || $6;
523         my $string = $3 || $5;
524         print "Found filter >>>$string<<<\n" if $debug;
525         substr $line, $LAST_MATCH_START[1], $LAST_MATCH_END[0] - $LAST_MATCH_START[0], '';
526
527         $string                         = unescape_template_string($string);
528         $cached{$file}{all}{$string}    = 1;
529         $cached{$file}{html}{$string}   = 1;
530         $cached{$file}{submit}{$string} = 1 if $PREMATCH =~ /$submitsearch/;
531         $plugins{needed}->{T8}          = 1 if $module eq '$T8';
532         $plugins{needed}->{LxERP}       = 1 if $module eq 'LxERP.t8';
533       }
534
535       while ($line =~ m/\[\%          # Template-Start-Tag
536                         [\-~#]?       # Whitespace-Unterdrückung
537                         \s*           # Optional beliebig viele Whitespace
538                         (?:           # Die erkannten Template-Direktiven
539                           PROCESS
540                         |
541                           INCLUDE
542                         )
543                         \s+           # Mindestens ein Whitespace
544                         [\'\"]?       # Anfang des Dateinamens
545                         ([^\s]+)      # Beliebig viele Nicht-Whitespaces -- Dateiname
546                         \.html        # Endung ".html", ansonsten kann es der Name eines Blocks sein
547                        /ix) {
548         my $new_file_name = "$basedir/templates/webpages/$1.html";
549         $cached{$file}{scanh}{$new_file_name} = 1;
550         substr $line, $LAST_MATCH_START[1], $LAST_MATCH_END[0] - $LAST_MATCH_START[0], '';
551       }
552     }
553
554     close(IN);
555
556     foreach my $plugin (keys %{ $plugins{needed} }) {
557       next if ($plugins{loaded}->{$plugin});
558       print "E: " . strip_base($file) . " requires the Template plugin '$plugin', but is not loaded with '[\% USE $plugin \%]'.\n";
559     }
560   }
561
562   # copy back into global arrays
563   $alllocales{$_} = 1            for keys %{$cached{$file}{all}};
564   $locale{$_}     = 1            for keys %{$cached{$file}{html}};
565   $submit{$_}     = 1            for keys %{$cached{$file}{submit}};
566
567   scanhtmlfile($_)               for keys %{$cached{$file}{scanh}};
568
569   $referenced_html_files{$_} = 1 for keys %{$cached{$file}{scanh}};
570 }
571
572 sub search_unused_htmlfiles {
573   my @unscanned_dirs = ('../../templates/webpages');
574
575   while (scalar @unscanned_dirs) {
576     my $dir = shift @unscanned_dirs;
577
578     foreach my $entry (<$dir/*>) {
579       if (-d $entry) {
580         push @unscanned_dirs, $entry;
581
582       } elsif (($entry =~ /_master.html$/) && -f $entry && !$referenced_html_files{$entry}) {
583         print "W: unused HTML template: " . strip_base($entry) . "\n";
584
585       }
586     }
587   }
588 }
589
590 sub strip_base {
591   my $s =  "$_[0]";             # Create a copy of the string.
592
593   $s    =~ s|^../../||;
594   $s    =~ s|templates/webpages/||;
595
596   return $s;
597 }
598
599 sub _single_quote {
600   my $val = shift;
601   $val =~ s/(\'|\\$)/\\$1/g;
602   return  "'" . $val .  "'";
603 }
604
605 sub _print_line {
606   my $key      = _single_quote(shift);
607   my $text     = _single_quote(shift);
608   my %params   = @_;
609   my $template = $params{template} || qq|  %-29s => %s,\n|;
610   my $fh       = $params{fh}       || croak 'need filehandle in _print_line';
611
612   print $fh sprintf $template, $key, $text;
613 }
614
615 sub generate_file {
616   my %params = @_;
617
618   my $file      = $params{file}   || croak 'need filename in generate_file';
619   my $header    = $params{header};
620   my $lines     = $params{data_sub};
621   my $data_name = $params{data_name};
622   my @delim     = split //, ($params{delim} || '{}');
623
624   open my $fh, '>:encoding(utf8)', $file or die "$! : $file";
625
626   $charset =~ s/\r?\n//g;
627   my $emacs_charset = lc $charset;
628
629   print $fh "#!/usr/bin/perl\n# -*- coding: $emacs_charset; -*-\n# vim: fenc=$charset\n\nuse utf8;\n\n";
630   print $fh $header, "\n" if $header;
631   print $fh "$data_name = $delim[0]\n" if $data_name;
632
633   $lines->(fh => $fh);
634
635   print $fh qq|$delim[1];\n\n1;\n|;
636   close $fh;
637 }
638
639 sub slurp {
640   my $file = shift;
641   do { local ( @ARGV, $/ ) = $file; <> }
642 }
643
644 __END__
645
646 =head1 NAME
647
648 locales.pl - Collect strings for translation in Lx-Office
649
650 =head1 SYNOPSIS
651
652 locales.pl [options] lang_code
653
654  Options:
655   -n, --no-custom-files  Do not process files whose name contains "_"
656   -c, --check-files      Run extended checks on HTML files
657   -v, --verbose          Be more verbose
658   -h, --help             Show this help
659
660 =head1 OPTIONS
661
662 =over 8
663
664 =item B<-n>, B<--no-custom-files>
665
666 Do not process files whose name contains "_", e.g. "custom_io.pl".
667
668 =item B<-c>, B<--check-files>
669
670 Run extended checks on the usage of templates. This can be used to
671 discover HTML templates that are never used as well as the usage of
672 non-existing HTML templates.
673
674 =item B<-v>, B<--verbose>
675
676 Be more verbose.
677
678 =back
679
680 =head1 DESCRIPTION
681
682 This script collects strings from Perl files, the menu.ini file and
683 HTML templates and puts them into the file "all" for translation.
684
685 =cut