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