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