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