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