intltool-merge.in

   1 #!@INTLTOOL_PERL@ -w
   2
   3 #
   4 #  The Intltool Message Merger
   5 #
   6 #  Copyright (C) 2000, 2003 Free Software Foundation.
   7 #  Copyright (C) 2000, 2001 Eazel, Inc
   8 #
   9 #  Intltool is free software; you can redistribute it and/or
  10 #  modify it under the terms of the GNU General Public License
  11 #  version 2 published by the Free Software Foundation.
  12 #
  13 #  Intltool is distributed in the hope that it will be useful,
  14 #  but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  16 #  General Public License for more details.
  17 #
  18 #  You should have received a copy of the GNU General Public License
  19 #  along with this program; if not, write to the Free Software
  20 #  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  21 #
  22 #  As a special exception to the GNU General Public License, if you
  23 #  distribute this file as part of a program that contains a
  24 #  configuration script generated by Autoconf, you may include it under
  25 #  the same distribution terms that you use for the rest of that program.
  26 #
  27 #  Authors:  Maciej Stachowiak <mjs@noisehavoc.org>
  28 #            Kenneth Christiansen <kenneth@gnu.org>
  29 #            Darin Adler <darin@bentspoon.com>
  30 #
  31 #  Proper XML UTF-8'ification written by Cyrille Chepelov <chepelov@calixo.net>
  32 #
  33
  34 ## Release information
  35 my $PROGRAM = "intltool-merge";
  36 my $PACKAGE = "intltool";
  37 my $VERSION = "0.26";
  38
  39 ## Loaded modules
  40 use strict;
  41 use Getopt::Long;
  42 use Text::Wrap;
  43
  44 ## Scalars used by the option stuff
  45 my $HELP_ARG = 0;
  46 my $VERSION_ARG = 0;
  47 my $BA_STYLE_ARG = 0;
  48 my $XML_STYLE_ARG = 0;
  49 my $KEYS_STYLE_ARG = 0;
  50 my $DESKTOP_STYLE_ARG = 0;
  51 my $SCHEMAS_STYLE_ARG = 0;
  52 my $RFC822DEB_STYLE_ARG = 0;
  53 my $QUIET_ARG = 0;
  54 my $PASS_THROUGH_ARG = 0;
  55 my $UTF8_ARG = 0;
  56 my $cache_file;
  57
  58 ## Handle options
  59 GetOptions
  60 (
  61  "help" => \$HELP_ARG,
  62  "version" => \$VERSION_ARG,
  63  "quiet|q" => \$QUIET_ARG,
  64  "oaf-style|o" => \$BA_STYLE_ARG, ## for compatibility
  65  "ba-style|b" => \$BA_STYLE_ARG,
  66  "xml-style|x" => \$XML_STYLE_ARG,
  67  "keys-style|k" => \$KEYS_STYLE_ARG,
  68  "desktop-style|d" => \$DESKTOP_STYLE_ARG,
  69  "schemas-style|s" => \$SCHEMAS_STYLE_ARG,
  70  "rfc822deb-style|r" => \$RFC822DEB_STYLE_ARG,
  71  "pass-through|p" => \$PASS_THROUGH_ARG,
  72  "utf8|u" => \$UTF8_ARG,
  73  "cache|c=s" => \$cache_file
  74  ) or &error;
  75
  76 my $PO_DIR;
  77 my $FILE;
  78 my $OUTFILE;
  79
  80 my %po_files_by_lang = ();
  81 my %translations = ();
  82 my $iconv = $ENV{"INTLTOOL_ICONV"} || "iconv";
  83
  84 # Use this instead of \w for XML files to handle more possible characters.
  85 my $w = "[-A-Za-z0-9._:]";
  86
  87 # XML quoted string contents
  88 my $q = "[^\\\"]*";
  89
  90 ## Check for options.
  91
  92 if ($VERSION_ARG)
  93 {
  94         &print_version;
  95 }
  96 elsif ($HELP_ARG)
  97 {
  98         &print_help;
  99 }
 100 elsif ($BA_STYLE_ARG && @ARGV > 2)
 101 {
 102         &preparation;
 103         &print_message;
 104         &ba_merge_translations;
 105         &finalize;
 106 }
 107 elsif ($XML_STYLE_ARG && @ARGV > 2)
 108 {
 109         &utf8_sanity_check;
 110         &preparation;
 111         &print_message;
 112         &xml_merge_translations;
 113         &finalize;
 114 }
 115 elsif ($KEYS_STYLE_ARG && @ARGV > 2)
 116 {
 117         &utf8_sanity_check;
 118         &preparation;
 119         &print_message;
 120         &keys_merge_translations;
 121         &finalize;
 122 }
 123 elsif ($DESKTOP_STYLE_ARG && @ARGV > 2)
 124 {
 125         &preparation;
 126         &print_message;
 127         &desktop_merge_translations;
 128         &finalize;
 129 }
 130 elsif ($SCHEMAS_STYLE_ARG && @ARGV > 2)
 131 {
 132         &preparation;
 133         &print_message;
 134         &schemas_merge_translations;
 135         &finalize;
 136 }
 137 elsif ($RFC822DEB_STYLE_ARG && @ARGV > 2)
 138 {
 139         &preparation;
 140         &print_message;
 141         &rfc822deb_merge_translations;
 142         &finalize;
 143 }
 144 else
 145 {
 146         &print_help;
 147 }
 148
 149 exit;
 150
 151 ## Sub for printing release information
 152 sub print_version
 153 {
 154     print <<_EOF_;
 155 ${PROGRAM} (${PACKAGE}) ${VERSION}
 156 Written by Maciej Stachowiak, Darin Adler and Kenneth Christiansen.
 157
 158 Copyright (C) 2000-2003 Free Software Foundation, Inc.
 159 Copyright (C) 2000-2001 Eazel, Inc.
 160 This is free software; see the source for copying conditions.  There is NO
 161 warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 162 _EOF_
 163     exit;
 164 }
 165
 166 ## Sub for printing usage information
 167 sub print_help
 168 {
 169     print <<_EOF_;
 170 Usage: ${PROGRAM} [OPTION]... PO_DIRECTORY FILENAME OUTPUT_FILE
 171 Generates an output file that includes some localized attributes from an
 172 untranslated source file.
 173
 174 Mandatory options: (exactly one must be specified)
 175   -b, --ba-style         includes translations in the bonobo-activation style
 176   -d, --desktop-style    includes translations in the desktop style
 177   -k, --keys-style       includes translations in the keys style
 178   -s, --schemas-style    includes translations in the schemas style
 179   -r, --rfc822deb-style  includes translations in the RFC822 style
 180   -x, --xml-style        includes translations in the standard xml style
 181
 182 Other options:
 183   -u, --utf8             convert all strings to UTF-8 before merging
 184   -p, --pass-through     use strings as found in .po files, without
 185                          conversion (STRONGLY unrecommended with -x)
 186   -c, --cache=FILE       specify cache file name
 187                          (usually \$top_builddir/po/.intltool-merge-cache)
 188   -q, --quiet            suppress most messages
 189       --help             display this help and exit
 190       --version          output version information and exit
 191
 192 Report bugs to http://bugzilla.gnome.org/ (product name "$PACKAGE")
 193 or send email to <xml-i18n-tools\@gnome.org>.
 194 _EOF_
 195     exit;
 196 }
 197
 198
 199 ## Sub for printing error messages
 200 sub print_error
 201 {
 202     print STDERR "Try `${PROGRAM} --help' for more information.\n";
 203     exit;
 204 }
 205
 206
 207 sub print_message
 208 {
 209     print "Merging translations into $OUTFILE.\n" unless $QUIET_ARG;
 210 }
 211
 212
 213 sub preparation
 214 {
 215     $PO_DIR = $ARGV[0];
 216     $FILE = $ARGV[1];
 217     $OUTFILE = $ARGV[2];
 218
 219     &gather_po_files;
 220     &get_translation_database;
 221 }
 222
 223 # General-purpose code for looking up translations in .po files
 224
 225 sub po_file2lang
 226 {
 227     my ($tmp) = @_;
 228     $tmp =~ s/^.*\/(.*)\.po$/$1/;
 229     return $tmp;
 230 }
 231
 232 sub gather_po_files
 233 {
 234     for my $po_file (glob "$PO_DIR/*.po") {
 235         $po_files_by_lang{po_file2lang($po_file)} = $po_file;
 236     }
 237 }
 238
 239 sub get_local_charset
 240 {
 241     my ($encoding) = @_;
 242     my $alias_file = $ENV{"G_CHARSET_ALIAS"} || "/gnome/head/INSTALL/lib/charset.alias";
 243
 244     # seek character encoding aliases in charset.alias (glib)
 245
 246     if (open CHARSET_ALIAS, $alias_file)
 247     {
 248         while (<CHARSET_ALIAS>)
 249         {
 250             next if /^\#/;
 251             return $1 if (/^\s*([-._a-zA-Z0-9]+)\s+$encoding\b/i)
 252         }
 253
 254         close CHARSET_ALIAS;
 255     }
 256
 257     # if not found, return input string
 258
 259     return $encoding;
 260 }
 261
 262 sub get_po_encoding
 263 {
 264     my ($in_po_file) = @_;
 265     my $encoding = "";
 266
 267     open IN_PO_FILE, $in_po_file or die;
 268     while (<IN_PO_FILE>)
 269     {
 270         ## example: "Content-Type: text/plain; charset=ISO-8859-1\n"
 271         if (/Content-Type\:.*charset=([-a-zA-Z0-9]+)\\n/)
 272         {
 273             $encoding = $1;
 274             last;
 275         }
 276     }
 277     close IN_PO_FILE;
 278
 279     if (!$encoding)
 280     {
 281         print STDERR "Warning: no encoding found in $in_po_file. Assuming ISO-8859-1\n" unless $QUIET_ARG;
 282         $encoding = "ISO-8859-1";
 283     }
 284
 285     system ("$iconv -f $encoding -t UTF-8 </dev/null 2>/dev/null");
 286     if ($?) {
 287         $encoding = get_local_charset($encoding);
 288     }
 289
 290     return $encoding
 291 }
 292
 293 sub utf8_sanity_check
 294 {
 295     if (!$UTF8_ARG)
 296     {
 297         if (!$PASS_THROUGH_ARG)
 298         {
 299             $PASS_THROUGH_ARG="1";
 300         }
 301     }
 302 }
 303
 304 sub get_translation_database
 305 {
 306     if ($cache_file) {
 307         &get_cached_translation_database;
 308     } else {
 309         &create_translation_database;
 310     }
 311 }
 312
 313 sub get_newest_po_age
 314 {
 315     my $newest_age;
 316
 317     foreach my $file (values %po_files_by_lang)
 318     {
 319         my $file_age = -M $file;
 320         $newest_age = $file_age if !$newest_age || $file_age < $newest_age;
 321     }
 322
 323     $newest_age = 0 if !$newest_age;
 324
 325     return $newest_age;
 326 }
 327
 328 sub create_cache
 329 {
 330     print "Generating and caching the translation database\n" unless $QUIET_ARG;
 331
 332     &create_translation_database;
 333
 334     open CACHE, ">$cache_file" || die;
 335     print CACHE join "\x01", %translations;
 336     close CACHE;
 337 }
 338
 339 sub load_cache
 340 {
 341     print "Found cached translation database\n" unless $QUIET_ARG;
 342
 343     my $contents;
 344     open CACHE, "<$cache_file" || die;
 345     {
 346         local $/;
 347         $contents = <CACHE>;
 348     }
 349     close CACHE;
 350     %translations = split "\x01", $contents;
 351 }
 352
 353 sub get_cached_translation_database
 354 {
 355     my $cache_file_age = -M $cache_file;
 356     if (defined $cache_file_age)
 357     {
 358         if ($cache_file_age <= &get_newest_po_age)
 359         {
 360             &load_cache;
 361             return;
 362         }
 363         print "Found too-old cached translation database\n" unless $QUIET_ARG;
 364     }
 365
 366     &create_cache;
 367 }
 368
 369 sub create_translation_database
 370 {
 371     for my $lang (keys %po_files_by_lang)
 372     {
 373         my $po_file = $po_files_by_lang{$lang};
 374
 375         if ($UTF8_ARG)
 376         {
 377             my $encoding = get_po_encoding ($po_file);
 378
 379             if (lc $encoding eq "utf-8")
 380             {
 381                 open PO_FILE, "<$po_file";
 382             }
 383             else
 384             {
 385                 print STDERR "WARNING: $po_file is not in UTF-8 but $encoding, converting...\n" unless $QUIET_ARG;;
 386
 387                 open PO_FILE, "$iconv -f $encoding -t UTF-8 $po_file|";
 388             }
 389         }
 390         else
 391         {
 392             open PO_FILE, "<$po_file";
 393         }
 394
 395         my $nextfuzzy = 0;
 396         my $inmsgid = 0;
 397         my $inmsgstr = 0;
 398         my $msgid = "";
 399         my $msgstr = "";
 400
 401         while (<PO_FILE>)
 402         {
 403             $nextfuzzy = 1 if /^#, fuzzy/;
 404
 405             if (/^msgid "((\\.|[^\\])*)"/ )
 406             {
 407                 $translations{$lang, $msgid} = $msgstr if $inmsgstr && $msgid && $msgstr;
 408                 $msgid = "";
 409                 $msgstr = "";
 410
 411                 if ($nextfuzzy) {
 412                     $inmsgid = 0;
 413                 } else {
 414                     $msgid = unescape_po_string($1);
 415                     $inmsgid = 1;
 416                 }
 417                 $inmsgstr = 0;
 418                 $nextfuzzy = 0;
 419             }
 420
 421             if (/^msgstr "((\\.|[^\\])*)"/)
 422             {
 423                 $msgstr = unescape_po_string($1);
 424                 $inmsgstr = 1;
 425                 $inmsgid = 0;
 426             }
 427
 428             if (/^"((\\.|[^\\])*)"/)
 429             {
 430                 $msgid .= unescape_po_string($1) if $inmsgid;
 431                 $msgstr .= unescape_po_string($1) if $inmsgstr;
 432             }
 433         }
 434         $translations{$lang, $msgid} = $msgstr if $inmsgstr && $msgid && $msgstr;
 435     }
 436 }
 437
 438 sub finalize
 439 {
 440 }
 441
 442 sub unescape_one_sequence
 443 {
 444     my ($sequence) = @_;
 445
 446     return "\\" if $sequence eq "\\\\";
 447     return "\"" if $sequence eq "\\\"";
 448     return "\n" if $sequence eq "\\n";
 449
 450     # gettext also handles \n, \t, \b, \r, \f, \v, \a, \xxx (octal),
 451     # \xXX (hex) and has a comment saying they want to handle \u and \U.
 452
 453     return $sequence;
 454 }
 455
 456 sub unescape_po_string
 457 {
 458     my ($string) = @_;
 459
 460     $string =~ s/(\\.)/unescape_one_sequence($1)/eg;
 461
 462     return $string;
 463 }
 464
 465 ## NOTE: deal with < - &lt; but not > - &gt;  because it seems its ok to have
 466 ## > in the entity. For further info please look at #84738.
 467 sub entity_decode
 468 {
 469     local ($_) = @_;
 470
 471     s/&apos;/'/g; # '
 472     s/&quot;/"/g; # "
 473     s/&amp;/&/g;
 474     s/&lt;/</g;
 475
 476     return $_;
 477 }
 478
 479 # entity_encode: (string)
 480 #
 481 # Encode the given string to XML format (encode '<' etc). It also
 482 # encodes high bit if not in UTF-8 mode.
 483
 484 sub entity_encode
 485 {
 486     my ($pre_encoded) = @_;
 487
 488     my @list_of_chars = unpack ('C*', $pre_encoded);
 489
 490     if ($PASS_THROUGH_ARG)
 491     {
 492         return join ('', map (&entity_encode_int_even_high_bit, @list_of_chars));
 493     }
 494     else
 495     {
 496         # with UTF-8 we only encode minimalistic
 497         return join ('', map (&entity_encode_int_minimalist, @list_of_chars));
 498     }
 499 }
 500
 501 sub entity_encode_int_minimalist
 502 {
 503     return "&quot;" if $_ == 34;
 504     return "&amp;" if $_ == 38;
 505     return "&apos;" if $_ == 39;
 506     return "&lt;" if $_ == 60;
 507     return chr $_;
 508 }
 509
 510 sub entity_encode_int_even_high_bit
 511 {
 512     if ($_ > 127 || $_ == 34 || $_ == 38 || $_ == 39 || $_ == 60)
 513     {
 514         # the ($_ > 127) should probably be removed
 515         return "&#" . $_ . ";";
 516     }
 517     else
 518     {
 519         return chr $_;
 520     }
 521 }
 522
 523 sub entity_encoded_translation
 524 {
 525     my ($lang, $string) = @_;
 526
 527     my $translation = $translations{$lang, $string};
 528     return $string if !$translation;
 529     return entity_encode ($translation);
 530 }
 531
 532 ## XML (bonobo-activation specific) merge code
 533
 534 sub ba_merge_translations
 535 {
 536     my $source;
 537
 538     {
 539        local $/; # slurp mode
 540        open INPUT, "<$FILE" or die "can't open $FILE: $!";
 541        $source = <INPUT>;
 542        close INPUT;
 543     }
 544
 545     open OUTPUT, ">$OUTFILE" or die "can't open $OUTFILE: $!";
 546
 547     while ($source =~ s|^(.*?)([ \t]*<\s*$w+\s+($w+\s*=\s*"$q"\s*)+/?>)([ \t]*\n)?||s)
 548     {
 549         print OUTPUT $1;
 550
 551         my $node = $2 . "\n";
 552
 553         my @strings = ();
 554         $_ = $node;
 555         while (s/(\s)_($w+\s*=\s*"($q)")/$1$2/s) {
 556              push @strings, entity_decode($3);
 557         }
 558         print OUTPUT;
 559
 560         my %langs;
 561         for my $string (@strings)
 562         {
 563             for my $lang (keys %po_files_by_lang)
 564             {
 565                 $langs{$lang} = 1 if $translations{$lang, $string};
 566             }
 567         }
 568
 569         for my $lang (sort keys %langs)
 570         {
 571             $_ = $node;
 572             s/(\sname\s*=\s*)"($q)"/$1"$2-$lang"/s;
 573             s/(\s)_($w+\s*=\s*")($q)"/$1 . $2 . entity_encoded_translation($lang, $3) . '"'/seg;
 574             print OUTPUT;
 575         }
 576     }
 577
 578     print OUTPUT $source;
 579
 580     close OUTPUT;
 581 }
 582
 583
 584 ## XML (non-bonobo-activation) merge code
 585
 586 sub xml_merge_translations
 587 {
 588     my $source;
 589
 590     {
 591        local $/; # slurp mode
 592        open INPUT, "<$FILE" or die "can't open $FILE: $!";
 593        $source = <INPUT>;
 594        close INPUT;
 595     }
 596
 597     open OUTPUT, ">$OUTFILE" or die;
 598
 599     # FIXME: support attribute translations
 600
 601     # Empty nodes never need translation, so unmark all of them.
 602     # For example, <_foo/> is just replaced by <foo/>.
 603     $source =~ s|<\s*_($w+)\s*/>|<$1/>|g;
 604
 605     # Support for <_foo>blah</_foo> style translations.
 606     while ($source =~ s|^(.*?)([ \t]*)<\s*_($w+)\s*>(.*?)<\s*/_\3\s*>([ \t]*\n)?||s)
 607     {
 608         print OUTPUT $1;
 609
 610         my $spaces = $2;
 611         my $tag = $3;
 612         my $string = $4;
 613
 614         print OUTPUT "$spaces<$tag>$string</$tag>\n";
 615
 616         $string =~ s/\s+/ /g;
 617         $string =~ s/^ //;
 618         $string =~ s/ $//;
 619         $string = entity_decode($string);
 620
 621         for my $lang (sort keys %po_files_by_lang)
 622         {
 623             my $translation = $translations{$lang, $string};
 624             next if !$translation;
 625             $translation = entity_encode($translation);
 626             print OUTPUT "$spaces<$tag xml:lang=\"$lang\">$translation</$tag>\n";
 627         }
 628     }
 629
 630     print OUTPUT $source;
 631
 632     close OUTPUT;
 633 }
 634
 635 sub keys_merge_translations
 636 {
 637     open INPUT, "<${FILE}" or die;
 638     open OUTPUT, ">${OUTFILE}" or die;
 639
 640     while (<INPUT>)
 641     {
 642         if (s/^(\s*)_(\w+=(.*))/$1$2/)
 643         {
 644             my $string = $3;
 645
 646             print OUTPUT;
 647
 648             my $non_translated_line = $_;
 649
 650             for my $lang (sort keys %po_files_by_lang)
 651             {
 652                 my $translation = $translations{$lang, $string};
 653                 next if !$translation;
 654
 655                 $_ = $non_translated_line;
 656                 s/(\w+)=.*/[$lang]$1=$translation/;
 657                 print OUTPUT;
 658             }
 659         }
 660         else
 661         {
 662             print OUTPUT;
 663         }
 664     }
 665
 666     close OUTPUT;
 667     close INPUT;
 668 }
 669
 670 sub desktop_merge_translations
 671 {
 672     open INPUT, "<${FILE}" or die;
 673     open OUTPUT, ">${OUTFILE}" or die;
 674
 675     while (<INPUT>)
 676     {
 677         if (s/^(\s*)_(\w+=(.*))/$1$2/)
 678         {
 679             my $string = $3;
 680
 681             print OUTPUT;
 682
 683             my $non_translated_line = $_;
 684
 685             for my $lang (sort keys %po_files_by_lang)
 686             {
 687                 my $translation = $translations{$lang, $string};
 688                 next if !$translation;
 689
 690                 $_ = $non_translated_line;
 691                 s/(\w+)=.*/${1}[$lang]=$translation/;
 692                 print OUTPUT;
 693             }
 694         }
 695         else
 696         {
 697             print OUTPUT;
 698         }
 699     }
 700
 701     close OUTPUT;
 702     close INPUT;
 703 }
 704
 705 sub schemas_merge_translations
 706 {
 707     my $source;
 708
 709     {
 710        local $/; # slurp mode
 711        open INPUT, "<$FILE" or die "can't open $FILE: $!";
 712        $source = <INPUT>;
 713        close INPUT;
 714     }
 715
 716     open OUTPUT, ">$OUTFILE" or die;
 717
 718     # FIXME: support attribute translations
 719
 720     # Empty nodes never need translation, so unmark all of them.
 721     # For example, <_foo/> is just replaced by <foo/>.
 722     $source =~ s|<\s*_($w+)\s*/>|<$1/>|g;
 723
 724     while ($source =~ s/
 725                         (.*?)
 726                         (\s+)(<locale\ name="C">(\s*)
 727                             (<default>\s*(.*?)\s*<\/default>)?(\s*)
 728                             (<short>\s*(.*?)\s*<\/short>)?(\s*)
 729                             (<long>\s*(.*?)\s*<\/long>)?(\s*)
 730                         <\/locale>)
 731                        //sx)
 732     {
 733         print OUTPUT $1;
 734
 735         my $locale_start_spaces = $2 ? $2 : '';
 736         my $default_spaces = $4 ? $4 : '';
 737         my $short_spaces = $7 ? $7 : '';
 738         my $long_spaces = $10 ? $10 : '';
 739         my $locale_end_spaces = $13 ? $13 : '';
 740         my $c_default_block = $3 ? $3 : '';
 741         my $default_string = $6 ? $6 : '';
 742         my $short_string = $9 ? $9 : '';
 743         my $long_string = $12 ? $12 : '';
 744
 745         $c_default_block =~ s/default>\[.*?\]/default>/s;
 746
 747         print OUTPUT "$locale_start_spaces$c_default_block";
 748
 749         $default_string =~ s/\s+/ /g;
 750         $default_string = entity_decode($default_string);
 751         $short_string =~ s/\s+/ /g;
 752         $short_string = entity_decode($short_string);
 753         $long_string =~ s/\s+/ /g;
 754         $long_string = entity_decode($long_string);
 755
 756         for my $lang (sort keys %po_files_by_lang)
 757         {
 758             my $default_translation = $translations{$lang, $default_string};
 759             my $short_translation = $translations{$lang, $short_string};
 760             my $long_translation  = $translations{$lang, $long_string};
 761
 762             next if (!$default_translation && !$short_translation &&
 763                      !$long_translation);
 764
 765             print OUTPUT "\n$locale_start_spaces<locale name=\"$lang\">";
 766
 767         print OUTPUT "$default_spaces";
 768
 769         if ($default_translation)
 770         {
 771             $default_translation = entity_encode($default_translation);
 772             print OUTPUT "<default>$default_translation</default>";
 773         }
 774
 775             print OUTPUT "$short_spaces";
 776
 777             if ($short_translation)
 778             {
 779                         $short_translation = entity_encode($short_translation);
 780                         print OUTPUT "<short>$short_translation</short>";
 781             }
 782
 783             print OUTPUT "$long_spaces";
 784
 785             if ($long_translation)
 786             {
 787                         $long_translation = entity_encode($long_translation);
 788                         print OUTPUT "<long>$long_translation</long>";
 789             }
 790
 791             print OUTPUT "$locale_end_spaces</locale>";
 792         }
 793     }
 794
 795     print OUTPUT $source;
 796
 797     close OUTPUT;
 798 }
 799
 800 sub rfc822deb_merge_translations
 801 {
 802     my $source;
 803
 804     $Text::Wrap::huge = 'overflow';
 805
 806     {
 807        local $/; # slurp mode
 808        open INPUT, "<$FILE" or die "can't open $FILE: $!";
 809        $source = <INPUT>;
 810        close INPUT;
 811     }
 812
 813     open OUTPUT, ">${OUTFILE}" or die;
 814
 815     while ($source =~ /(^|\n+)(_)?([^:_\n]+)(:\s*)(.*?)(?=\n[\S\n]|$)/sg)
 816     {
 817             my $sep = $1;
 818             my $non_translated_line = $3.$4;
 819             my $string = $5;
 820             my $is_translatable = defined($2);
 821             #  Remove [] dummy strings
 822             $string =~ s/\[\s[^\[\]]*\]$//;
 823             $non_translated_line .= $string;
 824
 825             print OUTPUT $sep.$non_translated_line;
 826
 827             if ($is_translatable)
 828             {
 829                 my @str_list = rfc822deb_split($string);
 830
 831                 for my $lang (sort keys %po_files_by_lang)
 832                 {
 833                     my $is_translated = 1;
 834                     my $str_translated = '';
 835                     my $first = 1;
 836
 837                     for my $str (@str_list)
 838                     {
 839                         my $translation = $translations{$lang, $str};
 840
 841                         if (!$translation)
 842                         {
 843                             $is_translated = 0;
 844                             last;
 845                         }
 846
 847                         #  $translation may also contain [] dummy
 848                         #  strings, mostly to indicate an empty string
 849                         $translation =~ s/\[\s[^\[\]]*\]$//;
 850
 851                         if ($first)
 852                         {
 853                             $str_translated .=
 854                                 Text::Tabs::expand($translation) .
 855                                 "\n";
 856                         }
 857                         else
 858                         {
 859                             $str_translated .= Text::Tabs::expand(
 860                                 Text::Wrap::wrap(' ', ' ', $translation)) .
 861                                 "\n .\n";
 862                         }
 863                         $first = 0;
 864
 865                         #  To fix some problems with Text::Wrap::wrap
 866                         $str_translated =~ s/(\n )+\n/\n .\n/g;
 867                     }
 868                     next unless $is_translated;
 869
 870                     $str_translated =~ s/\n \.\n$//;
 871                     $str_translated =~ s/\s+$//;
 872
 873                     $_ = $non_translated_line;
 874                     s/^(\w+):\s*.*/$sep${1}-$lang: $str_translated/s;
 875                     print OUTPUT;
 876                 }
 877             }
 878     }
 879     print OUTPUT "\n";
 880
 881     close OUTPUT;
 882     close INPUT;
 883 }
 884
 885 sub rfc822deb_split
 886 {
 887     # Debian defines a special way to deal with rfc822-style files:
 888     # when a value contain newlines, it consists of
 889     #   1.  a short form (first line)
 890     #   2.  a long description, all lines begin with a space,
 891     #       and paragraphs are separated by a single dot on a line
 892     # This routine returns an array of all paragraphs, and reformat
 893     # them.
 894     my $text = shift;
 895     $text =~ s/^ //mg;
 896     return ($text) if $text !~ /\n/;
 897
 898     $text =~ s/([^\n]*)\n//;
 899     my @list = ($1);
 900     my $str = '';
 901
 902     for my $line (split (/\n/, $text))
 903     {
 904         chomp $line;
 905         $line =~ /\s+$/;
 906
 907         if ($line =~ /^\.$/)
 908         {
 909             #  New paragraph
 910             $str =~ s/\s*$//;
 911             push(@list, $str);
 912             $str = '';
 913         }
 914         elsif ($line =~ /^\s/)
 915         {
 916             #  Line which must not be reformatted
 917             $str .= "\n" if length ($str) && $str !~ /\n$/;
 918             $str .= $line."\n";
 919         }
 920         else
 921         {
 922             #  Continuation line, remove newline
 923             $str .= " " if length ($str) && $str !~ /[\n ]$/;
 924             $str .= $line;
 925         }
 926     }
 927
 928     $str =~ s/\s*$//;
 929     push(@list, $str) if length ($str);
 930
 931     return @list;
 932 }
 933