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