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