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