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