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 '{'."\n";
 144 my $first_entry = 1;
 145 for my $key (sort(keys(%jslocale))) {
 146   print $js_file (!$first_entry ? ',' : '') . _double_quote($key) .':'. _double_quote($self->{texts}{$key}) ."\n";
 147   $first_entry = 0;
 148 }
 149 print $js_file '}'."\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       # is this a template call?
 377       if (/(?:parse_html_template2?|render)\s*\(\s*[\"\']([\w\/]+)\s*[\"\']/) {
 378         my $new_file_base = "$basedir/templates/webpages/$1.";
 379         if (/parse_html_template2/) {
 380           print "E: " . strip_base($file) . " is still using 'parse_html_template2' for " . strip_base("${new_file_base}html") . ".\n";
 381         }
 382
 383         my $found_one = 0;
 384         foreach my $ext (qw(html js json)) {
 385           my $new_file = "${new_file_base}${ext}";
 386           if (-f $new_file) {
 387             $cached{$file}{scanh}{$new_file} = 1;
 388             print "." if $opt_v;
 389             $found_one = 1;
 390           }
 391         }
 392
 393         if ($opt_c && !$found_one) {
 394           print "W: missing HTML template: " . strip_base($new_file_base) . "{html,json,js} (referenced from " . strip_base($file) . ")\n";
 395         }
 396       }
 397
 398       my $rc = 1;
 399
 400       while ($rc) {
 401         if (/Locale/) {
 402           unless (/^use /) {
 403             my ($null, $country) = split(/,/);
 404             $country =~ s/^ +[\"\']//;
 405             $country =~ s/[\"\'].*//;
 406           }
 407         }
 408
 409         my $postmatch = "";
 410
 411         # is it a submit button before $locale->
 412         if (/$submitsearch/) {
 413           $postmatch = "$'";
 414           if ($` !~ /locale->text/) {
 415             $is_submit   = 1;
 416             $sub_line_no = $line_no;
 417           }
 418         }
 419
 420         my ($found) = / (?: locale->text | \b t8 ) \b .*? \(/x;
 421         $postmatch = "$'";
 422
 423         if ($found) {
 424           my $string;
 425           ($string, $_) = extract_text_between_parenthesis($fh, $postmatch);
 426           $postmatch = $_;
 427
 428           # if there is no $ in the string record it
 429           unless (($string =~ /\$\D.*/) || ("" eq $string)) {
 430
 431             # this guarantees one instance of string
 432             $cached{$file}{locale}{$string} = 1;
 433
 434             # this one is for all the locales
 435             $cached{$file}{all}{$string} = 1;
 436
 437             # is it a submit button before $locale->
 438             if ($is_submit) {
 439               $cached{$file}{submit}{$string} = 1;
 440             }
 441           }
 442         } elsif ($postmatch =~ />/) {
 443           $is_submit = 0;
 444         }
 445
 446         # exit loop if there are no more locales on this line
 447         ($rc) = ($postmatch =~ /locale->text | \b t8/x);
 448
 449         if (   ($postmatch =~ />/)
 450             || (!$found && ($sub_line_no != $line_no) && />/)) {
 451           $is_submit = 0;
 452         }
 453       }
 454     }
 455
 456     close($fh);
 457
 458   }
 459
 460   $alllocales{$_} = 1             for keys %{$cached{$file}{all}};
 461   $locale{$_}     = 1             for keys %{$cached{$file}{locale}};
 462   $submit{$_}     = 1             for keys %{$cached{$file}{submit}};
 463
 464   scanfile($_, 0, $scanned_files) for keys %{$cached{$file}{scan}};
 465   scanfile($_, 1, $scanned_files) for keys %{$cached{$file}{scannosubs}};
 466   scanhtmlfile($_)                for keys %{$cached{$file}{scanh}};
 467
 468   $referenced_html_files{$_} = 1  for keys %{$cached{$file}{scanh}};
 469 }
 470
 471 sub scanmenu {
 472   my $file = shift;
 473
 474   my $fh = new FileHandle;
 475   open $fh, "$file" or die "$! : $file";
 476
 477   my @a = grep m/^\[/, <$fh>;
 478   close($fh);
 479
 480   # strip []
 481   grep { s/(\[|\])//g } @a;
 482
 483   foreach my $item (@a) {
 484     my @b = split /--/, $item;
 485     foreach my $string (@b) {
 486       chomp $string;
 487       $locale{$string}     = 1;
 488       $alllocales{$string} = 1;
 489     }
 490   }
 491
 492 }
 493
 494 sub unescape_template_string {
 495   my $in =  "$_[0]";
 496   $in    =~ s/\\(.)/$1/g;
 497   return $in;
 498 }
 499
 500 sub scanhtmlfile {
 501   local *IN;
 502
 503   my $file = shift;
 504
 505   if (!defined $cached{$file}) {
 506     my %plugins = ( 'loaded' => { }, 'needed' => { } );
 507
 508     open(IN, $file) || die $file;
 509
 510     my $copying  = 0;
 511     my $issubmit = 0;
 512     my $text     = "";
 513     while (my $line = <IN>) {
 514       chomp($line);
 515
 516       while ($line =~ m/\[\%[^\w]*use[^\w]+(\w+)[^\w]*?\%\]/gi) {
 517         $plugins{loaded}->{$1} = 1;
 518       }
 519
 520       while ($line =~ m/\[\%[^\w]*(\w+)\.\w+\(/g) {
 521         my $plugin = $1;
 522         $plugins{needed}->{$plugin} = 1 if (first { $_ eq $plugin } qw(HTML LxERP JavaScript MultiColumnIterator L));
 523       }
 524
 525       while ($line =~ m/(?:             # Start von Variante 1: LxERP.t8('...'); ohne darumliegende [% ... %]-Tags
 526                           (LxERP\.t8)\( #   LxERP.t8(                             ::Parameter $1::
 527                           ([\'\"])      #   Anfang des zu übersetzenden Strings   ::Parameter $2::
 528                           (.*?)         #   Der zu übersetzende String            ::Parameter $3::
 529                           (?<!\\)\2     #   Ende des zu übersetzenden Strings
 530                         |               # Start von Variante 2: [% '...' | $T8 %]
 531                           \[\%          #   Template-Start-Tag
 532                           [\-~#]?       #   Whitespace-Unterdrückung
 533                           \s*           #   Optional beliebig viele Whitespace
 534                           ([\'\"])      #   Anfang des zu übersetzenden Strings   ::Parameter $4::
 535                           (.*?)         #   Der zu übersetzende String            ::Parameter $5::
 536                           (?<!\\)\4     #   Ende des zu übersetzenden Strings
 537                           \s*\|\s*      #   Pipe-Zeichen mit optionalen Whitespace davor und danach
 538                           (\$T8)        #   Filteraufruf                          ::Parameter $6::
 539                           .*?           #   Optionale Argumente für den Filter
 540                           \s*           #   Whitespaces
 541                           [\-~#]?       #   Whitespace-Unterdrückung
 542                           \%\]          #   Template-Ende-Tag
 543                         )
 544                        /ix) {
 545         my $module = $1 || $6;
 546         my $string = $3 || $5;
 547         print "Found filter >>>$string<<<\n" if $debug;
 548         substr $line, $LAST_MATCH_START[1], $LAST_MATCH_END[0] - $LAST_MATCH_START[0], '';
 549
 550         $string                         = unescape_template_string($string);
 551         $cached{$file}{all}{$string}    = 1;
 552         $cached{$file}{html}{$string}   = 1;
 553         $cached{$file}{submit}{$string} = 1 if $PREMATCH =~ /$submitsearch/;
 554         $plugins{needed}->{T8}          = 1 if $module eq '$T8';
 555         $plugins{needed}->{LxERP}       = 1 if $module eq 'LxERP.t8';
 556       }
 557
 558       while ($line =~ m/\[\%          # Template-Start-Tag
 559                         [\-~#]?       # Whitespace-Unterdrückung
 560                         \s*           # Optional beliebig viele Whitespace
 561                         (?:           # Die erkannten Template-Direktiven
 562                           PROCESS
 563                         |
 564                           INCLUDE
 565                         )
 566                         \s+           # Mindestens ein Whitespace
 567                         [\'\"]?       # Anfang des Dateinamens
 568                         ([^\s]+)      # Beliebig viele Nicht-Whitespaces -- Dateiname
 569                         \.html        # Endung ".html", ansonsten kann es der Name eines Blocks sein
 570                        /ix) {
 571         my $new_file_name = "$basedir/templates/webpages/$1.html";
 572         $cached{$file}{scanh}{$new_file_name} = 1;
 573         substr $line, $LAST_MATCH_START[1], $LAST_MATCH_END[0] - $LAST_MATCH_START[0], '';
 574       }
 575     }
 576
 577     close(IN);
 578
 579     foreach my $plugin (keys %{ $plugins{needed} }) {
 580       next if ($plugins{loaded}->{$plugin});
 581       print "E: " . strip_base($file) . " requires the Template plugin '$plugin', but is not loaded with '[\% USE $plugin \%]'.\n";
 582     }
 583   }
 584
 585   # copy back into global arrays
 586   $alllocales{$_} = 1            for keys %{$cached{$file}{all}};
 587   $locale{$_}     = 1            for keys %{$cached{$file}{html}};
 588   $submit{$_}     = 1            for keys %{$cached{$file}{submit}};
 589
 590   scanhtmlfile($_)               for keys %{$cached{$file}{scanh}};
 591
 592   $referenced_html_files{$_} = 1 for keys %{$cached{$file}{scanh}};
 593 }
 594
 595 sub scan_javascript_file {
 596   my ($file) = @_;
 597
 598   open(my $fh, $file) || die('can not open file: '. $file);
 599
 600   while( my $line = readline($fh) ) {
 601     while( $line =~ m/
 602                     kivi.t8
 603                     \s*
 604                     \(
 605                     \s*
 606                     ([\'\"])
 607                     (.*?)
 608                     (?<!\\)\1
 609                     /ixg )
 610     {
 611       my $text = unescape_template_string($2);
 612
 613       $jslocale{$text} = 1;
 614       $alllocales{$text} = 1;
 615     }
 616   }
 617
 618   close($fh);
 619 }
 620 sub search_unused_htmlfiles {
 621   my @unscanned_dirs = ('../../templates/webpages');
 622
 623   while (scalar @unscanned_dirs) {
 624     my $dir = shift @unscanned_dirs;
 625
 626     foreach my $entry (<$dir/*>) {
 627       if (-d $entry) {
 628         push @unscanned_dirs, $entry;
 629
 630       } elsif (($entry =~ /_master.html$/) && -f $entry && !$referenced_html_files{$entry}) {
 631         print "W: unused HTML template: " . strip_base($entry) . "\n";
 632
 633       }
 634     }
 635   }
 636 }
 637
 638 sub strip_base {
 639   my $s =  "$_[0]";             # Create a copy of the string.
 640
 641   $s    =~ s|^../../||;
 642   $s    =~ s|templates/webpages/||;
 643
 644   return $s;
 645 }
 646
 647 sub _single_quote {
 648   my $val = shift;
 649   $val =~ s/(\'|\\$)/\\$1/g;
 650   return  "'" . $val .  "'";
 651 }
 652
 653 sub _double_quote {
 654   my $val = shift;
 655   $val =~ s/(\"|\\$)/\\$1/g;
 656   return  '"'. $val .'"';
 657 }
 658
 659 sub _print_line {
 660   my $key      = _single_quote(shift);
 661   my $text     = _single_quote(shift);
 662   my %params   = @_;
 663   my $template = $params{template} || qq|  %-29s => %s,\n|;
 664   my $fh       = $params{fh}       || croak 'need filehandle in _print_line';
 665
 666   print $fh sprintf $template, $key, $text;
 667 }
 668
 669 sub generate_file {
 670   my %params = @_;
 671
 672   my $file      = $params{file}   || croak 'need filename in generate_file';
 673   my $header    = $params{header};
 674   my $lines     = $params{data_sub};
 675   my $data_name = $params{data_name};
 676   my @delim     = split //, ($params{delim} || '{}');
 677
 678   open my $fh, '>:encoding(utf8)', $file or die "$! : $file";
 679
 680   $charset =~ s/\r?\n//g;
 681   my $emacs_charset = lc $charset;
 682
 683   print $fh "#!/usr/bin/perl\n# -*- coding: $emacs_charset; -*-\n# vim: fenc=$charset\n\nuse utf8;\n\n";
 684   print $fh $header, "\n" if $header;
 685   print $fh "$data_name = $delim[0]\n" if $data_name;
 686
 687   $lines->(fh => $fh);
 688
 689   print $fh qq|$delim[1];\n\n1;\n|;
 690   close $fh;
 691 }
 692
 693 sub slurp {
 694   my $file = shift;
 695   do { local ( @ARGV, $/ ) = $file; <> }
 696 }
 697
 698 __END__
 699
 700 =head1 NAME
 701
 702 locales.pl - Collect strings for translation in kivitendo
 703
 704 =head1 SYNOPSIS
 705
 706 locales.pl [options] lang_code
 707
 708  Options:
 709   -n, --no-custom-files  Do not process files whose name contains "_"
 710   -c, --check-files      Run extended checks on HTML files
 711   -v, --verbose          Be more verbose
 712   -h, --help             Show this help
 713
 714 =head1 OPTIONS
 715
 716 =over 8
 717
 718 =item B<-n>, B<--no-custom-files>
 719
 720 Do not process files whose name contains "_", e.g. "custom_io.pl".
 721
 722 =item B<-c>, B<--check-files>
 723
 724 Run extended checks on the usage of templates. This can be used to
 725 discover HTML templates that are never used as well as the usage of
 726 non-existing HTML templates.
 727
 728 =item B<-v>, B<--verbose>
 729
 730 Be more verbose.
 731
 732 =back
 733
 734 =head1 DESCRIPTION
 735
 736 This script collects strings from Perl files, the menu.ini file and
 737 HTML templates and puts them into the file "all" for translation.
 738
 739 =cut