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