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