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