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