scripts/locales.pl

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