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