intltool-merge.in

   1 #!@INTLTOOL_PERL@ -w
   2 # -*- Mode: perl; indent-tabs-mode: nil; c-basic-offset: 4  -*-
   3
   4 #
   5 #  The Intltool Message Merger
   6 #
   7 #  Copyright (C) 2000, 2003 Free Software Foundation.
   8 #  Copyright (C) 2000, 2001 Eazel, Inc
   9 #
  10 #  Intltool is free software; you can redistribute it and/or
  11 #  modify it under the terms of the GNU General Public License
  12 #  version 2 published by the Free Software Foundation.
  13 #
  14 #  Intltool is distributed in the hope that it will be useful,
  15 #  but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 #  General Public License for more details.
  18 #
  19 #  You should have received a copy of the GNU General Public License
  20 #  along with this program; if not, write to the Free Software
  21 #  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  22 #
  23 #  As a special exception to the GNU General Public License, if you
  24 #  distribute this file as part of a program that contains a
  25 #  configuration script generated by Autoconf, you may include it under
  26 #  the same distribution terms that you use for the rest of that program.
  27 #
  28 #  Authors:  Maciej Stachowiak <mjs@noisehavoc.org>
  29 #            Kenneth Christiansen <kenneth@gnu.org>
  30 #            Darin Adler <darin@bentspoon.com>
  31 #
  32 #  Proper XML UTF-8'ification written by Cyrille Chepelov <chepelov@calixo.net>
  33 #
  34
  35 ## Release information
  36 my $PROGRAM = "intltool-merge";
  37 my $PACKAGE = "@PACKAGE@";
  38 my $VERSION = "@VERSION@";
  39
  40 ## Loaded modules
  41 use strict;
  42 use Getopt::Long;
  43 use Text::Wrap;
  44 use File::Basename;
  45 use Encode;
  46
  47 my $must_end_tag      = -1;
  48 my $last_depth        = -1;
  49 my $translation_depth = -1;
  50 my @tag_stack = ();
  51 my @entered_tag = ();
  52 my @translation_strings = ();
  53 my $leading_space = "";
  54
  55 ## Scalars used by the option stuff
  56 my $HELP_ARG = 0;
  57 my $VERSION_ARG = 0;
  58 my $BA_STYLE_ARG = 0;
  59 my $XML_STYLE_ARG = 0;
  60 my $KEYS_STYLE_ARG = 0;
  61 my $DESKTOP_STYLE_ARG = 0;
  62 my $SCHEMAS_STYLE_ARG = 0;
  63 my $RFC822DEB_STYLE_ARG = 0;
  64 my $QUOTED_STYLE_ARG = 0;
  65 my $QUOTEDXML_STYLE_ARG = 0;
  66 my $QUIET_ARG = 0;
  67 my $PASS_THROUGH_ARG = 0;
  68 my $UTF8_ARG = 0;
  69 my $MULTIPLE_OUTPUT = 0;
  70 my $NO_TRANSLATIONS_ARG = 0;
  71 my $cache_file;
  72
  73 ## Handle options
  74 GetOptions
  75 (
  76  "help" => \$HELP_ARG,
  77  "version" => \$VERSION_ARG,
  78  "quiet|q" => \$QUIET_ARG,
  79  "oaf-style|o" => \$BA_STYLE_ARG, ## for compatibility
  80  "ba-style|b" => \$BA_STYLE_ARG,
  81  "xml-style|x" => \$XML_STYLE_ARG,
  82  "keys-style|k" => \$KEYS_STYLE_ARG,
  83  "desktop-style|d" => \$DESKTOP_STYLE_ARG,
  84  "schemas-style|s" => \$SCHEMAS_STYLE_ARG,
  85  "rfc822deb-style|r" => \$RFC822DEB_STYLE_ARG,
  86  "quoted-style" => \$QUOTED_STYLE_ARG,
  87  "quotedxml-style" => \$QUOTEDXML_STYLE_ARG,
  88  "pass-through|p" => \$PASS_THROUGH_ARG,
  89  "utf8|u" => \$UTF8_ARG,
  90  "multiple-output|m" => \$MULTIPLE_OUTPUT,
  91  "no-translations" => \$NO_TRANSLATIONS_ARG,
  92  "cache|c=s" => \$cache_file
  93  ) or &error;
  94
  95 my $PO_DIR;
  96 my $FILE;
  97 my $OUTFILE;
  98
  99 my %po_files_by_lang = ();
 100 my %translations = ();
 101
 102 # Use this instead of \w for XML files to handle more possible characters.
 103 my $w = "[-A-Za-z0-9._:]";
 104
 105 # XML quoted string contents
 106 my $q = "[^\\\"]*";
 107
 108 ## Check for options.
 109
 110 if ($VERSION_ARG)
 111 {
 112         &print_version;
 113 }
 114 elsif ($HELP_ARG)
 115 {
 116         &print_help;
 117 }
 118 elsif ($BA_STYLE_ARG && @ARGV > 2)
 119 {
 120         &utf8_sanity_check;
 121         &preparation;
 122         &print_message;
 123         &ba_merge_translations;
 124         &finalize;
 125 }
 126 elsif ($XML_STYLE_ARG && (@ARGV > 2 || ($NO_TRANSLATIONS_ARG && @ARGV > 1)))
 127 {
 128         &utf8_sanity_check;
 129         &preparation;
 130         &print_message;
 131         &xml_merge_output;
 132         &finalize;
 133 }
 134 elsif ($KEYS_STYLE_ARG && @ARGV > 2)
 135 {
 136         &utf8_sanity_check;
 137         &preparation;
 138         &print_message;
 139         &keys_merge_translations;
 140         &finalize;
 141 }
 142 elsif ($DESKTOP_STYLE_ARG && @ARGV > 2)
 143 {
 144         &utf8_sanity_check;
 145         &preparation;
 146         &print_message;
 147         &desktop_merge_translations;
 148         &finalize;
 149 }
 150 elsif ($SCHEMAS_STYLE_ARG && @ARGV > 2)
 151 {
 152         &utf8_sanity_check;
 153         &preparation;
 154         &print_message;
 155         &schemas_merge_translations;
 156         &finalize;
 157 }
 158 elsif ($RFC822DEB_STYLE_ARG && @ARGV > 2)
 159 {
 160         &preparation;
 161         &print_message;
 162         &rfc822deb_merge_translations;
 163         &finalize;
 164 }
 165 elsif (($QUOTED_STYLE_ARG || $QUOTEDXML_STYLE_ARG) && @ARGV > 2)
 166 {
 167         &utf8_sanity_check;
 168         &preparation;
 169         &print_message;
 170         &quoted_merge_translations($QUOTEDXML_STYLE_ARG);
 171         &finalize;
 172 }
 173 else
 174 {
 175         &print_help;
 176 }
 177
 178 exit;
 179
 180 ## Sub for printing release information
 181 sub print_version
 182 {
 183     print <<_EOF_;
 184 ${PROGRAM} (${PACKAGE}) ${VERSION}
 185 Written by Maciej Stachowiak, Darin Adler and Kenneth Christiansen.
 186
 187 Copyright (C) 2000-2003 Free Software Foundation, Inc.
 188 Copyright (C) 2000-2001 Eazel, Inc.
 189 This is free software; see the source for copying conditions.  There is NO
 190 warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 191 _EOF_
 192     exit;
 193 }
 194
 195 ## Sub for printing usage information
 196 sub print_help
 197 {
 198     print <<_EOF_;
 199 Usage: ${PROGRAM} [OPTION]... PO_DIRECTORY FILENAME OUTPUT_FILE
 200 Generates an output file that includes some localized attributes from an
 201 untranslated source file.
 202
 203 Mandatory options: (exactly one must be specified)
 204   -b, --ba-style         includes translations in the bonobo-activation style
 205   -d, --desktop-style    includes translations in the desktop style
 206   -k, --keys-style       includes translations in the keys style
 207   -s, --schemas-style    includes translations in the schemas style
 208   -r, --rfc822deb-style  includes translations in the RFC822 style
 209       --quoted-style     includes translations in the quoted string style
 210       --quotedxml-style  includes translations in the quoted xml string style
 211   -x, --xml-style        includes translations in the standard xml style
 212
 213 Other options:
 214   -u, --utf8             convert all strings to UTF-8 before merging
 215                          (default for everything except RFC822 style)
 216   -p, --pass-through     deprecated, does nothing and issues a warning
 217   -m, --multiple-output  output one localized file per locale, instead of
 218                          a single file containing all localized elements
 219       --no-translations  do not merge any translations: only generates the
 220                          unlocalised (English) version -- applies only
 221                          to XML merging
 222   -c, --cache=FILE       specify cache file name
 223                          (usually \$top_builddir/po/.intltool-merge-cache)
 224   -q, --quiet            suppress most messages
 225       --help             display this help and exit
 226       --version          output version information and exit
 227
 228 Report bugs to http://bugs.launchpad.net/intltool
 229 _EOF_
 230     exit;
 231 }
 232
 233
 234 ## Sub for printing error messages
 235 sub print_error
 236 {
 237     print STDERR "Try `${PROGRAM} --help' for more information.\n";
 238     exit;
 239 }
 240
 241
 242 sub print_message
 243 {
 244     print "Merging translations into $OUTFILE.\n" unless $QUIET_ARG;
 245 }
 246
 247
 248 sub preparation
 249 {
 250     if (!$XML_STYLE_ARG || !$NO_TRANSLATIONS_ARG) {
 251         $PO_DIR = $ARGV[0];
 252         $FILE = $ARGV[1];
 253         $OUTFILE = $ARGV[2];
 254
 255         &gather_po_files;
 256         &get_translation_database;
 257     } else {
 258         $FILE = $ARGV[0];
 259         $OUTFILE = $ARGV[1];
 260     }
 261 }
 262
 263 # General-purpose code for looking up translations in .po files
 264
 265 sub po_file2lang
 266 {
 267     my ($tmp) = @_;
 268     $tmp =~ s/^.*\/(.*)\.po$/$1/;
 269     return $tmp;
 270 }
 271
 272 sub gather_po_files
 273 {
 274     if (my $linguas = $ENV{"LINGUAS"})
 275     {
 276         for my $lang (split / /, $linguas) {
 277             my $po_file = $PO_DIR . "/" . $lang . ".po";
 278             if (-e $po_file) {
 279                 $po_files_by_lang{$lang} = $po_file;
 280             }
 281         }
 282     }
 283     else
 284     {
 285         if (open LINGUAS_FILE, "$PO_DIR/LINGUAS")
 286         {
 287             while (<LINGUAS_FILE>)
 288             {
 289                 next if /^#/;
 290
 291                 for my $lang (split)
 292                 {
 293                     chomp ($lang);
 294                     my $po_file = $PO_DIR . "/" . $lang . ".po";
 295                     if (-e $po_file) {
 296                         $po_files_by_lang{$lang} = $po_file;
 297                     }
 298                 }
 299             }
 300
 301             close LINGUAS_FILE;
 302         }
 303         else
 304         {
 305             for my $po_file (glob "$PO_DIR/*.po") {
 306                 $po_files_by_lang{po_file2lang($po_file)} = $po_file;
 307             }
 308         }
 309     }
 310 }
 311
 312 sub get_po_encoding
 313 {
 314     my ($in_po_file) = @_;
 315     my $encoding = "";
 316
 317     open IN_PO_FILE, $in_po_file or die;
 318     while (<IN_PO_FILE>)
 319     {
 320         ## example: "Content-Type: text/plain; charset=ISO-8859-1\n"
 321         if (/Content-Type\:.*charset=([-a-zA-Z0-9]+)\\n/)
 322         {
 323             $encoding = $1;
 324             last;
 325         }
 326     }
 327     close IN_PO_FILE;
 328
 329     if (!$encoding)
 330     {
 331         print STDERR "Warning: no encoding found in $in_po_file. Assuming ISO-8859-1\n" unless $QUIET_ARG;
 332         $encoding = "ISO-8859-1";
 333     }
 334
 335     return $encoding
 336 }
 337
 338 sub utf8_sanity_check
 339 {
 340     print STDERR "Warning: option --pass-through has been removed.\n" if $PASS_THROUGH_ARG;
 341     $UTF8_ARG = 1;
 342 }
 343
 344 sub get_translation_database
 345 {
 346     if ($cache_file) {
 347         &get_cached_translation_database;
 348     } else {
 349         &create_translation_database;
 350     }
 351 }
 352
 353 sub get_newest_po_age
 354 {
 355     my $newest_age;
 356
 357     foreach my $file (values %po_files_by_lang)
 358     {
 359         my $file_age = -M $file;
 360         $newest_age = $file_age if !$newest_age || $file_age < $newest_age;
 361     }
 362
 363     $newest_age = 0 if !$newest_age;
 364
 365     return $newest_age;
 366 }
 367
 368 sub create_cache
 369 {
 370     print "Generating and caching the translation database\n" unless $QUIET_ARG;
 371
 372     &create_translation_database;
 373
 374     open CACHE, ">$cache_file" || die;
 375     print CACHE join "\x01", %translations;
 376     close CACHE;
 377 }
 378
 379 sub load_cache
 380 {
 381     print "Found cached translation database\n" unless $QUIET_ARG;
 382
 383     my $contents;
 384     open CACHE, "<$cache_file" || die;
 385     {
 386         local $/;
 387         $contents = <CACHE>;
 388     }
 389     close CACHE;
 390     %translations = split "\x01", $contents;
 391 }
 392
 393 sub get_cached_translation_database
 394 {
 395     my $cache_file_age = -M $cache_file;
 396     if (defined $cache_file_age)
 397     {
 398         if ($cache_file_age <= &get_newest_po_age)
 399         {
 400             &load_cache;
 401             return;
 402         }
 403         print "Found too-old cached translation database\n" unless $QUIET_ARG;
 404     }
 405
 406     &create_cache;
 407 }
 408
 409 sub add_translation
 410 {
 411     my ($lang, $encoding, $msgctxt, $msgid, $msgstr) = @_;
 412
 413     return if !($msgid && $msgstr);
 414
 415     if ($msgctxt) {
 416         $msgid = "$msgctxt\004$msgid";
 417     }
 418     if (uc $encoding ne "UTF-8") {
 419         Encode::from_to ($msgid, $encoding, "UTF-8");
 420         Encode::from_to ($msgstr, $encoding, "UTF-8");
 421     }
 422     $translations{$lang, $msgid} = $msgstr;
 423 }
 424
 425 sub create_translation_database
 426 {
 427     for my $lang (keys %po_files_by_lang)
 428     {
 429         my $po_file = $po_files_by_lang{$lang};
 430         my $encoding = "UTF-8";
 431
 432         if ($UTF8_ARG)
 433         {
 434             $encoding = get_po_encoding ($po_file);
 435             if (uc $encoding ne "UTF-8") {
 436                 print "NOTICE: $po_file is not in UTF-8 but $encoding, converting...\n" unless $QUIET_ARG;;
 437             }
 438         }
 439         open PO_FILE, "<$po_file";
 440
 441         my $nextfuzzy = 0;
 442         my $inmsgctxt = 0;
 443         my $inmsgid = 0;
 444         my $inmsgstr = 0;
 445         my $msgctxt = "";
 446         my $msgid = "";
 447         my $msgstr = "";
 448
 449         while (<PO_FILE>)
 450         {
 451             $nextfuzzy = 1 if /^#, fuzzy/;
 452
 453             if (/^msgctxt "((\\.|[^\\]+)*)"/ )
 454             {
 455                 if ($inmsgstr) {
 456                     add_translation ($lang, $encoding,
 457                                      $msgctxt, $msgid, $msgstr);
 458                     $msgctxt = "";
 459                     $msgid = "";
 460                     $msgstr = "";
 461                 }
 462
 463                 $msgctxt = unescape_po_string($1);
 464                 $inmsgctxt = 1;
 465                 $inmsgid = 0;
 466                 $inmsgstr = 0;
 467             }
 468
 469             if (/^msgid "((\\.|[^\\]+)*)"/ )
 470             {
 471                 if ($inmsgstr) {
 472                     add_translation ($lang, $encoding,
 473                                      $msgctxt, $msgid, $msgstr);
 474                     $msgctxt = "";
 475                     $msgid = "";
 476                     $msgstr = "";
 477                 }
 478
 479                 if ($nextfuzzy) {
 480                     $inmsgid = 0;
 481                     $nextfuzzy = 0;
 482                 } else {
 483                     $msgid = unescape_po_string($1);
 484                     $inmsgid = 1;
 485                 }
 486                 $inmsgctxt = 0;
 487                 $inmsgstr = 0;
 488             }
 489
 490             if (/^msgstr "((\\.|[^\\]+)*)"/)
 491             {
 492                 $msgstr = unescape_po_string($1);
 493                 $inmsgstr = 1;
 494                 $inmsgctxt = 0;
 495                 $inmsgid = 0;
 496             }
 497
 498             if (/^"((\\.|[^\\]+)*)"/)
 499             {
 500                 $msgctxt .= unescape_po_string($1) if $inmsgctxt;
 501                 $msgid .= unescape_po_string($1) if $inmsgid;
 502                 $msgstr .= unescape_po_string($1) if $inmsgstr;
 503             }
 504         }
 505         add_translation ($lang, $encoding, $msgctxt, $msgid, $msgstr)
 506             if ($inmsgstr);
 507     }
 508 }
 509
 510 sub finalize
 511 {
 512 }
 513
 514 sub unescape_one_sequence
 515 {
 516     my ($sequence) = @_;
 517
 518     return "\\" if $sequence eq "\\\\";
 519     return "\"" if $sequence eq "\\\"";
 520     return "\n" if $sequence eq "\\n";
 521     return "\r" if $sequence eq "\\r";
 522     return "\t" if $sequence eq "\\t";
 523     return "\b" if $sequence eq "\\b";
 524     return "\f" if $sequence eq "\\f";
 525     return "\a" if $sequence eq "\\a";
 526     return chr(11) if $sequence eq "\\v"; # vertical tab, see ascii(7)
 527
 528     return chr(hex($1)) if ($sequence =~ /\\x([0-9a-fA-F]{2})/);
 529     return chr(oct($1)) if ($sequence =~ /\\([0-7]{3})/);
 530
 531     # FIXME: Is \0 supported as well? Kenneth and Rodney don't want it, see bug #48489
 532
 533     return $sequence;
 534 }
 535
 536 sub unescape_po_string
 537 {
 538     my ($string) = @_;
 539
 540     $string =~ s/(\\x[0-9a-fA-F]{2}|\\[0-7]{3}|\\.)/unescape_one_sequence($1)/eg;
 541
 542     return $string;
 543 }
 544
 545 sub entity_decode
 546 {
 547     local ($_) = @_;
 548
 549     s/&apos;/'/g; # '
 550     s/&quot;/"/g; # "
 551     s/&lt;/</g;
 552     s/&gt;/>/g;
 553     s/&amp;/&/g;
 554
 555     return $_;
 556 }
 557
 558 # entity_encode: (string)
 559 #
 560 # Encode the given string to XML format (encode '<' etc).
 561
 562 sub entity_encode
 563 {
 564     my ($pre_encoded) = @_;
 565
 566     my @list_of_chars = unpack ('C*', $pre_encoded);
 567
 568     # with UTF-8 we only encode minimalistic
 569     return join ('', map (&entity_encode_int_minimalist, @list_of_chars));
 570 }
 571
 572 sub entity_encode_int_minimalist
 573 {
 574     return "&quot;" if $_ == 34;
 575     return "&amp;" if $_ == 38;
 576     return "&apos;" if $_ == 39;
 577     return "&lt;" if $_ == 60;
 578     return "&gt;" if $_ == 62;
 579     return chr $_;
 580 }
 581
 582 sub entity_encoded_translation
 583 {
 584     my ($lang, $string) = @_;
 585
 586     my $translation = $translations{$lang, $string};
 587     return $string if !$translation;
 588     return entity_encode ($translation);
 589 }
 590
 591 ## XML (bonobo-activation specific) merge code
 592
 593 sub ba_merge_translations
 594 {
 595     my $source;
 596
 597     {
 598        local $/; # slurp mode
 599        open INPUT, "<$FILE" or die "can't open $FILE: $!";
 600        $source = <INPUT>;
 601        close INPUT;
 602     }
 603
 604     open OUTPUT, ">$OUTFILE" or die "can't open $OUTFILE: $!";
 605     # Binmode so that selftest works ok if using a native Win32 Perl...
 606     binmode (OUTPUT) if $^O eq 'MSWin32';
 607
 608     while ($source =~ s|^(.*?)([ \t]*<\s*$w+\s+($w+\s*=\s*"$q"\s*)+/?>)([ \t]*\n)?||s)
 609     {
 610         print OUTPUT $1;
 611
 612         my $node = $2 . "\n";
 613
 614         my @strings = ();
 615         $_ = $node;
 616         while (s/(\s)_($w+\s*=\s*"($q)")/$1$2/s) {
 617              push @strings, entity_decode($3);
 618         }
 619         print OUTPUT;
 620
 621         my %langs;
 622         for my $string (@strings)
 623         {
 624             for my $lang (keys %po_files_by_lang)
 625             {
 626                 $langs{$lang} = 1 if $translations{$lang, $string};
 627             }
 628         }
 629
 630         for my $lang (sort keys %langs)
 631         {
 632             $_ = $node;
 633             s/(\sname\s*=\s*)"($q)"/$1"$2-$lang"/s;
 634             s/(\s)_($w+\s*=\s*")($q)"/$1 . $2 . entity_encoded_translation($lang, $3) . '"'/seg;
 635             print OUTPUT;
 636         }
 637     }
 638
 639     print OUTPUT $source;
 640
 641     close OUTPUT;
 642 }
 643
 644
 645 ## XML (non-bonobo-activation) merge code
 646
 647
 648 # Process tag attributes
 649 #   Only parameter is a HASH containing attributes -> values mapping
 650 sub getAttributeString
 651 {
 652     my $sub = shift;
 653     my $do_translate = shift || 0;
 654     my $language = shift || "";
 655     my $result = "";
 656     my $translate = shift;
 657     foreach my $e (reverse(sort(keys %{ $sub }))) {
 658         my $key    = $e;
 659         my $string = $sub->{$e};
 660         my $quote = '"';
 661
 662         $string =~ s/^[\s]+//;
 663         $string =~ s/[\s]+$//;
 664
 665         if ($string =~ /^'.*'$/)
 666         {
 667             $quote = "'";
 668         }
 669         $string =~ s/^['"]//g;
 670         $string =~ s/['"]$//g;
 671
 672         if ($do_translate && $key =~ /^_/) {
 673             $key =~ s|^_||g;
 674             if ($language) {
 675                 # Handle translation
 676                 my $decode_string = entity_decode($string);
 677                 my $translation = $translations{$language, $decode_string};
 678                 if ($translation) {
 679                     $translation = entity_encode($translation);
 680                     $string = $translation;
 681                 }
 682                 $$translate = 2;
 683             } else {
 684                  $$translate = 2 if ($translate && (!$$translate)); # watch not to "overwrite" $translate
 685             }
 686         }
 687
 688         $result .= " $key=$quote$string$quote";
 689     }
 690     return $result;
 691 }
 692
 693 # Returns a translatable string from XML node, it works on contents of every node in XML::Parser tree
 694 sub getXMLstring
 695 {
 696     my $ref = shift;
 697     my $spacepreserve = shift || 0;
 698     my @list = @{ $ref };
 699     my $result = "";
 700
 701     my $count = scalar(@list);
 702     my $attrs = $list[0];
 703     my $index = 1;
 704
 705     $spacepreserve = 1 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/));
 706     $spacepreserve = 0 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?default["']?$/));
 707
 708     while ($index < $count) {
 709         my $type = $list[$index];
 710         my $content = $list[$index+1];
 711         if (! $type ) {
 712             # We've got CDATA
 713             if ($content) {
 714                 # lets strip the whitespace here, and *ONLY* here
 715                 $content =~ s/\s+/ /gs if (!$spacepreserve);
 716                 $result .= $content;
 717             }
 718         } elsif ( "$type" ne "1" ) {
 719             # We've got another element
 720             $result .= "<$type";
 721             $result .= getAttributeString(@{$content}[0], 0); # no nested translatable elements
 722             if ($content) {
 723                 my $subresult = getXMLstring($content, $spacepreserve);
 724                 if ($subresult) {
 725                     $result .= ">".$subresult . "</$type>";
 726                 } else {
 727                     $result .= "/>";
 728                 }
 729             } else {
 730                 $result .= "/>";
 731             }
 732         }
 733         $index += 2;
 734     }
 735     return $result;
 736 }
 737
 738 # Translate list of nodes if necessary
 739 sub translate_subnodes
 740 {
 741     my $fh = shift;
 742     my $content = shift;
 743     my $language = shift || "";
 744     my $singlelang = shift || 0;
 745     my $spacepreserve = shift || 0;
 746
 747     my @nodes = @{ $content };
 748
 749     my $count = scalar(@nodes);
 750     my $index = 0;
 751     while ($index < $count) {
 752         my $type = $nodes[$index];
 753         my $rest = $nodes[$index+1];
 754         if ($singlelang) {
 755             my $oldMO = $MULTIPLE_OUTPUT;
 756             $MULTIPLE_OUTPUT = 1;
 757             traverse($fh, $type, $rest, $language, $spacepreserve);
 758             $MULTIPLE_OUTPUT = $oldMO;
 759         } else {
 760             traverse($fh, $type, $rest, $language, $spacepreserve);
 761         }
 762         $index += 2;
 763     }
 764 }
 765
 766 sub isWellFormedXmlFragment
 767 {
 768     my $ret = eval 'require XML::Parser';
 769     if(!$ret) {
 770         die "You must have XML::Parser installed to run $0\n\n";
 771     }
 772
 773     my $fragment = shift;
 774     return 0 if (!$fragment);
 775
 776     $fragment = "<root>$fragment</root>";
 777     my $xp = new XML::Parser(Style => 'Tree');
 778     my $tree = 0;
 779     eval { $tree = $xp->parse($fragment); };
 780     return $tree;
 781 }
 782
 783 sub traverse
 784 {
 785     my $fh = shift;
 786     my $nodename = shift;
 787     my $content = shift;
 788     my $language = shift || "";
 789     my $spacepreserve = shift || 0;
 790
 791     if (!$nodename) {
 792         if ($content =~ /^[\s]*$/) {
 793             $leading_space .= $content;
 794         }
 795         print $fh $content;
 796     } else {
 797         # element
 798         my @all = @{ $content };
 799         my $attrs = shift @all;
 800         my $translate = 0;
 801         my $outattr = getAttributeString($attrs, 1, $language, \$translate);
 802
 803         if ($nodename =~ /^_/) {
 804             $translate = 1;
 805             $nodename =~ s/^_//;
 806         }
 807         my $lookup = '';
 808
 809         $spacepreserve = 0 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?default["']?$/));
 810         $spacepreserve = 1 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/));
 811
 812         print $fh "<$nodename", $outattr;
 813         if ($translate) {
 814             $content = getXMLstring($content, $spacepreserve);
 815             if (!$spacepreserve) {
 816                 $content =~ s/^\s+//s;
 817                 $content =~ s/\s+$//s;
 818             }
 819             if (exists $attrs->{"msgctxt"}) {
 820                 my $context = entity_decode ($attrs->{"msgctxt"});
 821                 $context =~ s/^["'](.*)["']/$1/;
 822                 $lookup = "$context\004$content";
 823             } else {
 824                 $lookup = $content;
 825             }
 826
 827             if ($lookup || $translate == 2) {
 828                 my $translation = $translations{$language, $lookup} if isWellFormedXmlFragment($translations{$language, $lookup});
 829                 if ($MULTIPLE_OUTPUT && ($translation || $translate == 2)) {
 830                     $translation = $content if (!$translation);
 831                     print $fh " xml:lang=\"", $language, "\"" if $language;
 832                     print $fh ">";
 833                     if ($translate == 2) {
 834                         translate_subnodes($fh, \@all, $language, 1, $spacepreserve);
 835                     } else {
 836                         print $fh $translation;
 837                     }
 838                     print $fh "</$nodename>";
 839
 840                     return; # this means there will be no same translation with xml:lang="$language"...
 841                             # if we want them both, just remove this "return"
 842                 } else {
 843                     print $fh ">";
 844                     if ($translate == 2) {
 845                         translate_subnodes($fh, \@all, $language, 1, $spacepreserve);
 846                     } else {
 847                         print $fh $content;
 848                     }
 849                     print $fh "</$nodename>";
 850                 }
 851             } else {
 852                 print $fh "/>";
 853             }
 854
 855             for my $lang (sort keys %po_files_by_lang) {
 856                     if ($MULTIPLE_OUTPUT && $lang ne "$language") {
 857                         next;
 858                     }
 859                     if ($lang) {
 860                         # Handle translation
 861                         #
 862                         my $translate = 0;
 863                         my $localattrs = getAttributeString($attrs, 1, $lang, \$translate);
 864                         my $translation = $translations{$lang, $lookup} if isWellFormedXmlFragment($translations{$lang, $lookup});
 865                         if ($translate && !$translation) {
 866                             $translation = $content;
 867                         }
 868
 869                         if ($translation || $translate) {
 870                             print $fh "\n";
 871                             $leading_space =~ s/.*\n//g;
 872                             print $fh $leading_space;
 873                             print $fh "<", $nodename, " xml:lang=\"", $lang, "\"", $localattrs, ">";
 874                             if ($translate == 2) {
 875                                translate_subnodes($fh, \@all, $lang, 1, $spacepreserve);
 876                             } else {
 877                                 print $fh $translation;
 878                             }
 879                             print $fh "</$nodename>";
 880                         }
 881                     }
 882             }
 883
 884         } else {
 885             my $count = scalar(@all);
 886             if ($count > 0) {
 887                 print $fh ">";
 888                 my $index = 0;
 889                 while ($index < $count) {
 890                     my $type = $all[$index];
 891                     my $rest = $all[$index+1];
 892                     traverse($fh, $type, $rest, $language, $spacepreserve);
 893                     $index += 2;
 894                 }
 895                 print $fh "</$nodename>";
 896             } else {
 897                 print $fh "/>";
 898             }
 899         }
 900     }
 901 }
 902
 903 sub intltool_tree_comment
 904 {
 905     my $expat = shift;
 906     my $data  = shift;
 907     my $clist = $expat->{Curlist};
 908     my $pos   = $#$clist;
 909
 910     push @$clist, 1 => $data;
 911 }
 912
 913 sub intltool_tree_cdatastart
 914 {
 915     my $expat    = shift;
 916     my $clist = $expat->{Curlist};
 917     my $pos   = $#$clist;
 918
 919     push @$clist, 0 => $expat->original_string();
 920 }
 921
 922 sub intltool_tree_cdataend
 923 {
 924     my $expat    = shift;
 925     my $clist = $expat->{Curlist};
 926     my $pos   = $#$clist;
 927
 928     $clist->[$pos] .= $expat->original_string();
 929 }
 930
 931 sub intltool_tree_char
 932 {
 933     my $expat = shift;
 934     my $text  = shift;
 935     my $clist = $expat->{Curlist};
 936     my $pos   = $#$clist;
 937
 938     # Use original_string so that we retain escaped entities
 939     # in CDATA sections.
 940     #
 941     if ($pos > 0 and $clist->[$pos - 1] eq '0') {
 942         $clist->[$pos] .= $expat->original_string();
 943     } else {
 944         push @$clist, 0 => $expat->original_string();
 945     }
 946 }
 947
 948 sub intltool_tree_start
 949 {
 950     my $expat    = shift;
 951     my $tag      = shift;
 952     my @origlist = ();
 953
 954     # Use original_string so that we retain escaped entities
 955     # in attribute values.  We must convert the string to an
 956     # @origlist array to conform to the structure of the Tree
 957     # Style.
 958     #
 959     my @original_array = split /\x/, $expat->original_string();
 960     my $source         = $expat->original_string();
 961
 962     # Remove leading tag.
 963     #
 964     $source =~ s|^\s*<\s*(\S+)||s;
 965
 966     # Grab attribute key/value pairs and push onto @origlist array.
 967     #
 968     while ($source)
 969     {
 970        if ($source =~ /^\s*([\w:-]+)\s*[=]\s*["]/)
 971        {
 972            $source =~ s|^\s*([\w:-]+)\s*[=]\s*["]([^"]*)["]||s;
 973            push @origlist, $1;
 974            push @origlist, '"' . $2 . '"';
 975        }
 976        elsif ($source =~ /^\s*([\w:-]+)\s*[=]\s*[']/)
 977        {
 978            $source =~ s|^\s*([\w:-]+)\s*[=]\s*[']([^']*)[']||s;
 979            push @origlist, $1;
 980            push @origlist, "'" . $2 . "'";
 981        }
 982        else
 983        {
 984            last;
 985        }
 986     }
 987
 988     my $ol = [ { @origlist } ];
 989
 990     push @{ $expat->{Lists} }, $expat->{Curlist};
 991     push @{ $expat->{Curlist} }, $tag => $ol;
 992     $expat->{Curlist} = $ol;
 993 }
 994
 995 sub readXml
 996 {
 997     my $filename = shift || return;
 998     if(!-f $filename) {
 999         die "ERROR Cannot find filename: $filename\n";
1000     }
1001
1002     my $ret = eval 'require XML::Parser';
1003     if(!$ret) {
1004         die "You must have XML::Parser installed to run $0\n\n";
1005     }
1006     my $xp = new XML::Parser(Style => 'Tree');
1007     $xp->setHandlers(Char => \&intltool_tree_char);
1008     $xp->setHandlers(Start => \&intltool_tree_start);
1009     $xp->setHandlers(CdataStart => \&intltool_tree_cdatastart);
1010     $xp->setHandlers(CdataEnd => \&intltool_tree_cdataend);
1011     my $tree = $xp->parsefile($filename);
1012
1013 # <foo><head id="a">Hello <em>there</em></head><bar>Howdy<ref/></bar>do</foo>
1014 # would be:
1015 # [foo, [{}, head, [{id => "a"}, 0, "Hello ",  em, [{}, 0, "there"]], bar, [{},
1016 # 0, "Howdy",  ref, [{}]], 0, "do" ] ]
1017
1018     return $tree;
1019 }
1020
1021 sub print_header
1022 {
1023     my $infile = shift;
1024     my $fh = shift;
1025     my $source;
1026
1027     if(!-f $infile) {
1028         die "ERROR Cannot find filename: $infile\n";
1029     }
1030
1031     print $fh qq{<?xml version="1.0" encoding="UTF-8"?>\n};
1032     {
1033         local $/;
1034         open DOCINPUT, "<${FILE}" or die;
1035         $source = <DOCINPUT>;
1036         close DOCINPUT;
1037     }
1038     if ($source =~ /(<!DOCTYPE.*\[.*\]\s*>)/s)
1039     {
1040         print $fh "$1\n";
1041     }
1042     elsif ($source =~ /(<!DOCTYPE[^>]*>)/s)
1043     {
1044         print $fh "$1\n";
1045     }
1046 }
1047
1048 sub parseTree
1049 {
1050     my $fh        = shift;
1051     my $ref       = shift;
1052     my $language  = shift || "";
1053
1054     my $name = shift @{ $ref };
1055     my $cont = shift @{ $ref };
1056
1057     while (!$name || "$name" eq "1") {
1058         $name = shift @{ $ref };
1059         $cont = shift @{ $ref };
1060     }
1061
1062     my $spacepreserve = 0;
1063     my $attrs = @{$cont}[0];
1064     $spacepreserve = 1 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/));
1065
1066     traverse($fh, $name, $cont, $language, $spacepreserve);
1067 }
1068
1069 sub xml_merge_output
1070 {
1071     my $source;
1072
1073     if ($MULTIPLE_OUTPUT) {
1074         for my $lang (sort keys %po_files_by_lang) {
1075             if ( ! -d $lang ) {
1076                 mkdir $lang or -d $lang or die "Cannot create subdirectory $lang: $!\n";
1077             }
1078             open OUTPUT, ">$lang/$OUTFILE" or die "Cannot open $lang/$OUTFILE: $!\n";
1079             binmode (OUTPUT) if $^O eq 'MSWin32';
1080             my $tree = readXml($FILE);
1081             print_header($FILE, \*OUTPUT);
1082             parseTree(\*OUTPUT, $tree, $lang);
1083             close OUTPUT;
1084             print "CREATED $lang/$OUTFILE\n" unless $QUIET_ARG;
1085         }
1086         if ( ! -d "C" ) {
1087             mkdir "C" or -d "C" or die "Cannot create subdirectory C: $!\n";
1088         }
1089         open OUTPUT, ">C/$OUTFILE" or die "Cannot open C/$OUTFILE: $!\n";
1090         binmode (OUTPUT) if $^O eq 'MSWin32';
1091         my $tree = readXml($FILE);
1092         print_header($FILE, \*OUTPUT);
1093         parseTree(\*OUTPUT, $tree);
1094         close OUTPUT;
1095         print "CREATED C/$OUTFILE\n" unless $QUIET_ARG;
1096     } else {
1097         open OUTPUT, ">$OUTFILE" or die "Cannot open $OUTFILE: $!\n";
1098         binmode (OUTPUT) if $^O eq 'MSWin32';
1099         my $tree = readXml($FILE);
1100         print_header($FILE, \*OUTPUT);
1101         parseTree(\*OUTPUT, $tree);
1102         close OUTPUT;
1103         print "CREATED $OUTFILE\n" unless $QUIET_ARG;
1104     }
1105 }
1106
1107 sub keys_merge_translation
1108 {
1109     my ($lang) = @_;
1110
1111     if ( ! -d $lang && $MULTIPLE_OUTPUT)
1112     {
1113         mkdir $lang or -d $lang or die "Cannot create subdirectory $lang: $!\n";
1114     }
1115
1116     open INPUT, "<${FILE}" or die "Cannot open ${FILE}: $!\n";
1117     open OUTPUT, ">$lang/$OUTFILE" or die "Cannot open $lang/$OUTFILE: $!\n";
1118     binmode (OUTPUT) if $^O eq 'MSWin32';
1119
1120     while (<INPUT>)
1121     {
1122         if (s/^(\s*)_(\w+=(.*))/$1$2/)
1123         {
1124             my $string = $3;
1125
1126             if (!$MULTIPLE_OUTPUT)
1127             {
1128                 print OUTPUT;
1129
1130                 my $non_translated_line = $_;
1131
1132                 for my $lang (sort keys %po_files_by_lang)
1133                 {
1134                     my $translation = $translations{$lang, $string};
1135                     next if !$translation;
1136
1137                     $_ = $non_translated_line;
1138                     s/(\w+)=.*/[$lang]$1=$translation/;
1139                     print OUTPUT;
1140                 }
1141             }
1142             else
1143             {
1144                 my $non_translated_line = $_;
1145                 my $translation = $translations{$lang, $string};
1146                 $translation = $string if !$translation;
1147
1148                 $_ = $non_translated_line;
1149                 s/(\w+)=.*/$1=$translation/;
1150                 print OUTPUT;
1151             }
1152         }
1153         else
1154         {
1155             print OUTPUT;
1156         }
1157     }
1158
1159     close OUTPUT;
1160     close INPUT;
1161
1162     print "CREATED $lang/$OUTFILE\n" unless $QUIET_ARG;
1163 }
1164
1165 sub keys_merge_translations
1166 {
1167     if ($MULTIPLE_OUTPUT)
1168     {
1169         for my $lang (sort keys %po_files_by_lang)
1170         {
1171             keys_merge_translation ($lang);
1172         }
1173         keys_merge_translation ("C");
1174     }
1175     else
1176     {
1177         keys_merge_translation (".");
1178     }
1179 }
1180
1181 sub desktop_merge_translations
1182 {
1183     open INPUT, "<${FILE}" or die;
1184     open OUTPUT, ">${OUTFILE}" or die;
1185     binmode (OUTPUT) if $^O eq 'MSWin32';
1186
1187     while (<INPUT>)
1188     {
1189         if (s/^(\s*)_([A-Za-z0-9\-]+=(.*))/$1$2/)
1190         {
1191             my $string = $3;
1192
1193             print OUTPUT;
1194
1195             my $non_translated_line = $_;
1196
1197             for my $lang (sort keys %po_files_by_lang)
1198             {
1199                 my $translation = $translations{$lang, $string};
1200                 next if !$translation;
1201
1202                 $_ = $non_translated_line;
1203                 s/(\w+)=.*/${1}[$lang]=$translation/;
1204                 print OUTPUT;
1205             }
1206         }
1207         else
1208         {
1209             print OUTPUT;
1210         }
1211     }
1212
1213     close OUTPUT;
1214     close INPUT;
1215 }
1216
1217 sub schemas_merge_translations
1218 {
1219     my $source;
1220
1221     {
1222        local $/; # slurp mode
1223        open INPUT, "<$FILE" or die "can't open $FILE: $!";
1224        $source = <INPUT>;
1225        close INPUT;
1226     }
1227
1228     open OUTPUT, ">$OUTFILE" or die;
1229     binmode (OUTPUT) if $^O eq 'MSWin32';
1230
1231     # FIXME: support attribute translations
1232
1233     # Empty nodes never need translation, so unmark all of them.
1234     # For example, <_foo/> is just replaced by <foo/>.
1235     $source =~ s|<\s*_($w+)\s*/>|<$1/>|g;
1236
1237     while ($source =~ s/
1238                         (.*?)
1239                         (\s+)(<locale\ name="C">(\s*)
1240                             (<default>\s*(?:<!--[^>]*?-->\s*)?(.*?)\s*<\/default>)?(\s*)
1241                             (<short>\s*(?:<!--[^>]*?-->\s*)?(.*?)\s*<\/short>)?(\s*)
1242                             (<long>\s*(?:<!--[^>]*?-->\s*)?(.*?)\s*<\/long>)?(\s*)
1243                         <\/locale>)
1244                        //sx)
1245     {
1246         print OUTPUT $1;
1247
1248         my $locale_start_spaces = $2 ? $2 : '';
1249         my $default_spaces = $4 ? $4 : '';
1250         my $short_spaces = $7 ? $7 : '';
1251         my $long_spaces = $10 ? $10 : '';
1252         my $locale_end_spaces = $13 ? $13 : '';
1253         my $c_default_block = $3 ? $3 : '';
1254         my $default_string = $6 ? $6 : '';
1255         my $short_string = $9 ? $9 : '';
1256         my $long_string = $12 ? $12 : '';
1257
1258         print OUTPUT "$locale_start_spaces$c_default_block";
1259
1260         $default_string =~ s/\s+/ /g;
1261         $default_string = entity_decode($default_string);
1262         $short_string =~ s/\s+/ /g;
1263         $short_string = entity_decode($short_string);
1264         $long_string =~ s/\s+/ /g;
1265         $long_string = entity_decode($long_string);
1266
1267         for my $lang (sort keys %po_files_by_lang)
1268         {
1269             my $default_translation = $translations{$lang, $default_string};
1270             my $short_translation = $translations{$lang, $short_string};
1271             my $long_translation  = $translations{$lang, $long_string};
1272
1273             next if (!$default_translation && !$short_translation &&
1274                      !$long_translation);
1275
1276             print OUTPUT "\n$locale_start_spaces<locale name=\"$lang\">";
1277
1278         print OUTPUT "$default_spaces";
1279
1280         if ($default_translation)
1281         {
1282             $default_translation = entity_encode($default_translation);
1283             print OUTPUT "<default>$default_translation</default>";
1284         }
1285
1286             print OUTPUT "$short_spaces";
1287
1288             if ($short_translation)
1289             {
1290                         $short_translation = entity_encode($short_translation);
1291                         print OUTPUT "<short>$short_translation</short>";
1292             }
1293
1294             print OUTPUT "$long_spaces";
1295
1296             if ($long_translation)
1297             {
1298                         $long_translation = entity_encode($long_translation);
1299                         print OUTPUT "<long>$long_translation</long>";
1300             }
1301
1302             print OUTPUT "$locale_end_spaces</locale>";
1303         }
1304     }
1305
1306     print OUTPUT $source;
1307
1308     close OUTPUT;
1309 }
1310
1311 sub rfc822deb_merge_translations
1312 {
1313     my %encodings = ();
1314     for my $lang (keys %po_files_by_lang) {
1315         $encodings{$lang} = ($UTF8_ARG ? 'UTF-8' : get_po_encoding($po_files_by_lang{$lang}));
1316     }
1317
1318     my $source;
1319
1320     $Text::Wrap::huge = 'overflow';
1321     $Text::Wrap::break = qr/\n|\s(?=\S)/;
1322
1323     {
1324        local $/; # slurp mode
1325        open INPUT, "<$FILE" or die "can't open $FILE: $!";
1326        $source = <INPUT>;
1327        close INPUT;
1328     }
1329
1330     open OUTPUT, ">${OUTFILE}" or die;
1331     binmode (OUTPUT) if $^O eq 'MSWin32';
1332
1333     while ($source =~ /(^|\n+)(_*)([^:\s]+)(:[ \t]*)(.*?)(?=\n[\S\n]|$)/sg)
1334     {
1335             my $sep = $1;
1336             my $non_translated_line = $3.$4;
1337             my $string = $5;
1338             my $underscore = length($2);
1339             next if $underscore eq 0 && $non_translated_line =~ /^#/;
1340             #  Remove [] dummy strings
1341             my $stripped = $string;
1342             $stripped =~ s/\[\s[^\[\]]*\],/,/g if $underscore eq 2;
1343             $stripped =~ s/\[\s[^\[\]]*\]$//;
1344             $non_translated_line .= $stripped;
1345
1346             print OUTPUT $sep.$non_translated_line;
1347
1348             if ($underscore)
1349             {
1350                 my @str_list = rfc822deb_split($underscore, $string);
1351
1352                 for my $lang (sort keys %po_files_by_lang)
1353                 {
1354                     my $is_translated = 1;
1355                     my $str_translated = '';
1356                     my $first = 1;
1357
1358                     for my $str (@str_list)
1359                     {
1360                         my $translation = $translations{$lang, $str};
1361
1362                         if (!$translation)
1363                         {
1364                             $is_translated = 0;
1365                             last;
1366                         }
1367
1368                         #  $translation may also contain [] dummy
1369                         #  strings, mostly to indicate an empty string
1370                         $translation =~ s/\[\s[^\[\]]*\]$//;
1371
1372                         if ($first)
1373                         {
1374                             if ($underscore eq 2)
1375                             {
1376                                 $str_translated .= $translation;
1377                             }
1378                             else
1379                             {
1380                                 $str_translated .=
1381                                     Text::Tabs::expand($translation) .
1382                                     "\n";
1383                             }
1384                         }
1385                         else
1386                         {
1387                             if ($underscore eq 2)
1388                             {
1389                                 $str_translated .= ', ' . $translation;
1390                             }
1391                             else
1392                             {
1393                                 $str_translated .= Text::Tabs::expand(
1394                                     Text::Wrap::wrap(' ', ' ', $translation)) .
1395                                     "\n .\n";
1396                             }
1397                         }
1398                         $first = 0;
1399
1400                         #  To fix some problems with Text::Wrap::wrap
1401                         $str_translated =~ s/(\n )+\n/\n .\n/g;
1402                     }
1403                     next unless $is_translated;
1404
1405                     $str_translated =~ s/\n \.\n$//;
1406                     $str_translated =~ s/\s+$//;
1407
1408                     $_ = $non_translated_line;
1409                     s/^(\w+):\s*.*/$sep${1}-$lang.$encodings{$lang}: $str_translated/s;
1410                     print OUTPUT;
1411                 }
1412             }
1413     }
1414     print OUTPUT "\n";
1415
1416     close OUTPUT;
1417     close INPUT;
1418 }
1419
1420 sub rfc822deb_split
1421 {
1422     # Debian defines a special way to deal with rfc822-style files:
1423     # when a value contain newlines, it consists of
1424     #   1.  a short form (first line)
1425     #   2.  a long description, all lines begin with a space,
1426     #       and paragraphs are separated by a single dot on a line
1427     # This routine returns an array of all paragraphs, and reformat
1428     # them.
1429     # When first argument is 2, the string is a comma separated list of
1430     # values.
1431     my $type = shift;
1432     my $text = shift;
1433     $text =~ s/^[ \t]//mg;
1434     return (split(/, */, $text, 0)) if $type ne 1;
1435     return ($text) if $text !~ /\n/;
1436
1437     $text =~ s/([^\n]*)\n//;
1438     my @list = ($1);
1439     my $str = '';
1440
1441     for my $line (split (/\n/, $text))
1442     {
1443         chomp $line;
1444         if ($line =~ /^\.\s*$/)
1445         {
1446             #  New paragraph
1447             $str =~ s/\s*$//;
1448             push(@list, $str);
1449             $str = '';
1450         }
1451         elsif ($line =~ /^\s/)
1452         {
1453             #  Line which must not be reformatted
1454             $str .= "\n" if length ($str) && $str !~ /\n$/;
1455             $line =~ s/\s+$//;
1456             $str .= $line."\n";
1457         }
1458         else
1459         {
1460             #  Continuation line, remove newline
1461             $str .= " " if length ($str) && $str !~ /\n$/;
1462             $str .= $line;
1463         }
1464     }
1465
1466     $str =~ s/\s*$//;
1467     push(@list, $str) if length ($str);
1468
1469     return @list;
1470 }
1471
1472 sub quoted_translation
1473 {
1474     my ($xml_mode, $lang, $string) = @_;
1475
1476     $string = entity_decode($string) if $xml_mode;
1477     $string =~ s/\\\"/\"/g;
1478
1479     my $translation = $translations{$lang, $string};
1480     $translation = $string if !$translation;
1481     $translation = entity_encode($translation) if $xml_mode;
1482     $translation =~ s/\"/\\\"/g;
1483     return $translation
1484 }
1485
1486 sub quoted_merge_translations
1487 {
1488     my ($xml_mode) = @_;
1489
1490     if (!$MULTIPLE_OUTPUT) {
1491         print "Quoted only supports Multiple Output.\n";
1492         exit(1);
1493     }
1494
1495     for my $lang (sort keys %po_files_by_lang) {
1496         if ( ! -d $lang ) {
1497             mkdir $lang or -d $lang or die "Cannot create subdirectory $lang: $!\n";
1498         }
1499         open INPUT, "<${FILE}" or die;
1500         open OUTPUT, ">$lang/$OUTFILE" or die "Cannot open $lang/$OUTFILE: $!\n";
1501         binmode (OUTPUT) if $^O eq 'MSWin32';
1502         while (<INPUT>)
1503         {
1504             s/\"(([^\"]|\\\")*[^\\\"])\"/"\"" . &quoted_translation($xml_mode, $lang, $1) . "\""/ge;
1505             print OUTPUT;
1506         }
1507         close OUTPUT;
1508         close INPUT;
1509     }
1510 }