intltool-extract.in

   1 #!@INTLTOOL_PERL@ -w
   2 # -*- Mode: perl; indent-tabs-mode: nil; c-basic-offset: 4  -*-
   3
   4 #
   5 #  The Intltool Message Extractor
   6 #
   7 #  Copyright (C) 2000-2001, 2003 Free Software Foundation.
   8 #
   9 #  Intltool is free software; you can redistribute it and/or
  10 #  modify it under the terms of the GNU General Public License as
  11 #  published by the Free Software Foundation; either version 2 of the
  12 #  License, or (at your option) any later version.
  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: Kenneth Christiansen <kenneth@gnu.org>
  29 #           Darin Adler <darin@bentspoon.com>
  30 #
  31
  32 ## Release information
  33 my $PROGRAM      = "intltool-extract";
  34 my $PACKAGE      = "@PACKAGE@";
  35 my $VERSION      = "@VERSION@";
  36
  37 ## Loaded modules
  38 use strict;
  39 use File::Basename;
  40 use Getopt::Long;
  41
  42 ## Scalars used by the option stuff
  43 my $TYPE_ARG    = "0";
  44 my $LOCAL_ARG   = "0";
  45 my $HELP_ARG    = "0";
  46 my $VERSION_ARG = "0";
  47 my $UPDATE_ARG  = "0";
  48 my $QUIET_ARG   = "0";
  49 my $SRCDIR_ARG  = ".";
  50 my $NOMSGCTXT_ARG = "0";
  51
  52 my $FILE;
  53 my $OUTFILE;
  54
  55 my $gettext_type = "";
  56 my $input;
  57 my %messages = ();
  58 my @messages_sorted = ();
  59 my %loc = ();
  60 my %count = ();
  61 my %comments = ();
  62 my $strcount = 0;
  63
  64 my $XMLCOMMENT = "";
  65
  66 ## Use this instead of \w for XML files to handle more possible characters.
  67 my $w = "[-A-Za-z0-9._:]";
  68
  69 ## Always print first
  70 $| = 1;
  71
  72 ## Handle options
  73 GetOptions (
  74             "type=s"     => \$TYPE_ARG,
  75             "local|l"    => \$LOCAL_ARG,
  76             "help|h"     => \$HELP_ARG,
  77             "version|v"  => \$VERSION_ARG,
  78             "update"     => \$UPDATE_ARG,
  79             "quiet|q"    => \$QUIET_ARG,
  80             "srcdir=s"   => \$SRCDIR_ARG,
  81             "nomsgctxt"  => \$NOMSGCTXT_ARG,
  82             ) or &error;
  83
  84 &split_on_argument;
  85
  86
  87 ## Check for options.
  88 ## This section will check for the different options.
  89
  90 sub split_on_argument {
  91
  92     if ($VERSION_ARG) {
  93         &version;
  94
  95     } elsif ($HELP_ARG) {
  96         &help;
  97
  98     } elsif ($LOCAL_ARG) {
  99         &place_local;
 100         &extract;
 101
 102     } elsif ($UPDATE_ARG) {
 103         &place_normal;
 104         &extract;
 105
 106     } elsif (@ARGV > 0) {
 107         &place_normal;
 108         &message;
 109         &extract;
 110
 111     } else {
 112         &help;
 113
 114     }
 115 }
 116
 117 sub place_normal {
 118     $FILE        = $ARGV[0];
 119     $OUTFILE     = "$FILE.h";
 120
 121     my $dirname = dirname ($OUTFILE);
 122     if (! -d "$dirname" && $dirname ne "") {
 123         system ("mkdir -p $dirname");
 124     }
 125 }
 126
 127 sub place_local {
 128     $FILE        = $ARGV[0];
 129     $OUTFILE     = fileparse($FILE, ());
 130     if (!-e "tmp/") {
 131         system("mkdir tmp/");
 132     }
 133     $OUTFILE     = "./tmp/$OUTFILE.h"
 134 }
 135
 136 sub determine_type {
 137    if ($TYPE_ARG =~ /^gettext\/(.*)/) {
 138         $gettext_type=$1
 139    }
 140 }
 141
 142 ## Sub for printing release information
 143 sub version{
 144     print <<_EOF_;
 145 ${PROGRAM} (${PACKAGE}) $VERSION
 146 Copyright (C) 2000, 2003 Free Software Foundation, Inc.
 147 Written by Kenneth Christiansen, 2000.
 148
 149 This is free software; see the source for copying conditions.  There is NO
 150 warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 151 _EOF_
 152     exit;
 153 }
 154
 155 ## Sub for printing usage information
 156 sub help {
 157     print <<_EOF_;
 158 Usage: ${PROGRAM} [OPTION]... [FILENAME]
 159 Generates a header file from an XML source file.
 160
 161 It grabs all strings between <_translatable_node> and its end tag in
 162 XML files. Read manpage (man ${PROGRAM}) for more info.
 163
 164       --type=TYPE   Specify the file type of FILENAME. Currently supports:
 165                     "gettext/glade", "gettext/ini", "gettext/keys"
 166                     "gettext/rfc822deb", "gettext/schemas",
 167                     "gettext/gsettings", "gettext/xml", "gettext/quoted",
 168                     "gettext/quotedxml", "gettext/tlk"
 169   -l, --local       Writes output into current working directory
 170                     (conflicts with --update)
 171       --update      Writes output into the same directory the source file
 172                     reside (conflicts with --local)
 173       --srcdir      Root of the source tree
 174   -v, --version     Output version information and exit
 175   -h, --help        Display this help and exit
 176   -q, --quiet       Quiet mode
 177
 178 Report bugs to http://bugs.launchpad.net/intltool
 179 _EOF_
 180     exit;
 181 }
 182
 183 ## Sub for printing error messages
 184 sub error{
 185     print STDERR "Try `${PROGRAM} --help' for more information.\n";
 186     exit;
 187 }
 188
 189 sub message {
 190     print "Generating C format header file for translation.\n" unless $QUIET_ARG;
 191 }
 192
 193 sub extract {
 194     &determine_type;
 195
 196     &convert;
 197
 198     open OUT, ">$OUTFILE";
 199     binmode (OUT) if $^O eq 'MSWin32';
 200     &msg_write;
 201     close OUT;
 202
 203     print "Wrote $OUTFILE\n" unless $QUIET_ARG;
 204 }
 205
 206 sub convert {
 207
 208     ## Reading the file
 209     {
 210         local (*IN);
 211         local $/; #slurp mode
 212         open (IN, "<$SRCDIR_ARG/$FILE") || die "can't open $SRCDIR_ARG/$FILE: $!";
 213         binmode (IN);
 214         $input = <IN>;
 215         close IN;
 216     }
 217
 218     &type_ini if $gettext_type eq "ini";
 219     &type_keys if $gettext_type eq "keys";
 220     &type_xml if $gettext_type eq "xml";
 221     &type_glade if $gettext_type eq "glade";
 222     &type_gsettings  if $gettext_type eq "gsettings";
 223     &type_schemas  if $gettext_type eq "schemas";
 224     &type_rfc822deb  if $gettext_type eq "rfc822deb";
 225     &type_quoted if $gettext_type eq "quoted";
 226     &type_quotedxml if $gettext_type eq "quotedxml";
 227     &type_tlk if $gettext_type eq "tlk";
 228 }
 229
 230 sub entity_decode_minimal
 231 {
 232     local ($_) = @_;
 233
 234     s/&apos;/'/g; # '
 235     s/&quot;/"/g; # "
 236     s/&amp;/&/g;
 237
 238     return $_;
 239 }
 240
 241 sub entity_decode
 242 {
 243     local ($_) = @_;
 244
 245     s/&apos;/'/g; # '
 246     s/&quot;/"/g; # "
 247     s/&lt;/</g;
 248     s/&gt;/>/g;
 249     s/&amp;/&/g;
 250
 251     return $_;
 252 }
 253
 254 sub escape_char
 255 {
 256     return '\"' if $_ eq '"';
 257     return '\n' if $_ eq "\n";
 258     return '\\\\' if $_ eq '\\';
 259
 260     return $_;
 261 }
 262
 263 sub escape
 264 {
 265     my ($string) = @_;
 266     return join "", map &escape_char, split //, $string;
 267 }
 268
 269 sub add_message
 270 {
 271     my ($string) = @_;
 272     push @messages_sorted, $string if !defined $messages{$string};
 273     $messages{$string} = [];
 274 }
 275
 276 sub type_ini {
 277     ### For generic translatable desktop files ###
 278     while ($input =~ /^(#(.+)\n)?^_.*=(.*)$/mg) {
 279         if (defined($2))  {
 280             $comments{$3} = $2;
 281         }
 282         add_message($3);
 283     }
 284 }
 285
 286 sub type_keys {
 287     ### For generic translatable mime/keys files ###
 288     while ($input =~ /^\s*_\w+=(.*)$/mg) {
 289         add_message($1);
 290     }
 291 }
 292
 293 sub type_xml {
 294     ### For generic translatable XML files ###
 295     my $tree = readXml($input);
 296     parseTree(0, $tree);
 297 }
 298
 299 sub print_var {
 300     my $var = shift;
 301     my $vartype = ref $var;
 302
 303     if ($vartype =~ /ARRAY/) {
 304         my @arr = @{$var};
 305         print "[ ";
 306         foreach my $el (@arr) {
 307             print_var($el);
 308             print ", ";
 309         }
 310         print "] ";
 311     } elsif ($vartype =~ /HASH/) {
 312         my %hash = %{$var};
 313         print "{ ";
 314         foreach my $key (keys %hash) {
 315             print "$key => ";
 316             print_var($hash{$key});
 317             print ", ";
 318         }
 319         print "} ";
 320     } else {
 321         print $var;
 322     }
 323 }
 324
 325 # Same syntax as getAttributeString in intltool-merge.in.in, similar logic (look for ## differences comment)
 326 sub getAttributeString
 327 {
 328     my $sub = shift;
 329     my $do_translate = shift || 1;
 330     my $language = shift || "";
 331     my $translate = shift;
 332     my $result = "";
 333     foreach my $e (reverse(sort(keys %{ $sub }))) {
 334         my $key    = $e;
 335         my $string = $sub->{$e};
 336         my $quote = '"';
 337
 338         $string =~ s/^[\s]+//;
 339         $string =~ s/[\s]+$//;
 340
 341         if ($string =~ /^'.*'$/)
 342         {
 343             $quote = "'";
 344         }
 345         $string =~ s/^['"]//g;
 346         $string =~ s/['"]$//g;
 347
 348         ## differences from intltool-merge.in.in
 349         if ($key =~ /^_/) {
 350             $comments{entity_decode($string)} = $XMLCOMMENT if $XMLCOMMENT;
 351             add_message(entity_decode($string));
 352             $$translate = 2;
 353         }
 354         ## differences end here from intltool-merge.in.in
 355         $result .= " $key=$quote$string$quote";
 356     }
 357     return $result;
 358 }
 359
 360 # Verbatim copy from intltool-merge.in.in
 361 sub getXMLstring
 362 {
 363     my $ref = shift;
 364     my $spacepreserve = shift || 0;
 365     my @list = @{ $ref };
 366     my $result = "";
 367
 368     my $count = scalar(@list);
 369     my $attrs = $list[0];
 370     my $index = 1;
 371
 372     $spacepreserve = 1 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/));
 373     $spacepreserve = 0 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?default["']?$/));
 374
 375     while ($index < $count) {
 376         my $type = $list[$index];
 377         my $content = $list[$index+1];
 378         if (! $type ) {
 379             # We've got CDATA
 380             if ($content) {
 381                 # lets strip the whitespace here, and *ONLY* here
 382                 $content =~ s/\s+/ /gs if (!$spacepreserve);
 383                 $result .= $content;
 384             }
 385         } elsif ( "$type" ne "1" ) {
 386             # We've got another element
 387             $result .= "<$type";
 388             $result .= getAttributeString(@{$content}[0], 0); # no nested translatable elements
 389             if ($content) {
 390                 my $subresult = getXMLstring($content, $spacepreserve);
 391                 if ($subresult) {
 392                     $result .= ">".$subresult . "</$type>";
 393                 } else {
 394                     $result .= "/>";
 395                 }
 396             } else {
 397                 $result .= "/>";
 398             }
 399         }
 400         $index += 2;
 401     }
 402     return $result;
 403 }
 404
 405 # Verbatim copy from intltool-merge.in.in, except for MULTIPLE_OUTPUT handling removed
 406 # Translate list of nodes if necessary
 407 sub translate_subnodes
 408 {
 409     my $fh = shift;
 410     my $content = shift;
 411     my $language = shift || "";
 412     my $singlelang = shift || 0;
 413     my $spacepreserve = shift || 0;
 414
 415     my @nodes = @{ $content };
 416
 417     my $count = scalar(@nodes);
 418     my $index = 0;
 419     while ($index < $count) {
 420         my $type = $nodes[$index];
 421         my $rest = $nodes[$index+1];
 422         traverse($fh, $type, $rest, $language, $spacepreserve);
 423         $index += 2;
 424     }
 425 }
 426
 427 # Based on traverse() in intltool-merge.in.in
 428 sub traverse
 429 {
 430     my $fh = shift; # unused, to allow us to sync code between -merge and -extract
 431     my $nodename = shift;
 432     my $content = shift;
 433     my $language = shift || "";
 434     my $spacepreserve = shift || 0;
 435
 436     if ($nodename && "$nodename" eq "1") {
 437         $XMLCOMMENT = $content;
 438     } elsif ($nodename) {
 439         # element
 440         my @all = @{ $content };
 441         my $attrs = shift @all;
 442         my $translate = 0;
 443         my $outattr = getAttributeString($attrs, 1, $language, \$translate);
 444
 445         if ($nodename =~ /^_/) {
 446             $translate = 1;
 447             $nodename =~ s/^_//;
 448         }
 449         my $lookup = '';
 450
 451         $spacepreserve = 0 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?default["']?$/));
 452         $spacepreserve = 1 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/));
 453
 454         if ($translate) {
 455             $lookup = getXMLstring($content, $spacepreserve);
 456             if (!$spacepreserve) {
 457                 $lookup =~ s/^\s+//s;
 458                 $lookup =~ s/\s+$//s;
 459             }
 460             if (exists $attrs->{"msgctxt"}) {
 461                 my $context = entity_decode ($attrs->{"msgctxt"});
 462                 $context =~ s/^["'](.*)["']/$1/;
 463                 $lookup = "$context\004$lookup";
 464             }
 465
 466             if ($lookup && $translate != 2) {
 467                 $comments{$lookup} = $XMLCOMMENT if $XMLCOMMENT;
 468                 add_message($lookup);
 469             } elsif ($translate == 2) {
 470                 translate_subnodes($fh, \@all, $language, 1, $spacepreserve);
 471             }
 472         } else {
 473             $XMLCOMMENT = "";
 474             my $count = scalar(@all);
 475             if ($count > 0) {
 476                 my $index = 0;
 477                 while ($index < $count) {
 478                     my $type = $all[$index];
 479                     my $rest = $all[$index+1];
 480                     traverse($fh, $type, $rest, $language, $spacepreserve);
 481                     $index += 2;
 482                 }
 483             }
 484         }
 485         $XMLCOMMENT = "";
 486     }
 487 }
 488
 489
 490 # Verbatim copy from intltool-merge.in.in, $fh for compatibility
 491 sub parseTree
 492 {
 493     my $fh        = shift;
 494     my $ref       = shift;
 495     my $language  = shift || "";
 496
 497     my $name = shift @{ $ref };
 498     my $cont = shift @{ $ref };
 499
 500     while (!$name || "$name" eq "1") {
 501         $name = shift @{ $ref };
 502         $cont = shift @{ $ref };
 503     }
 504
 505     my $spacepreserve = 0;
 506     my $attrs = @{$cont}[0];
 507     $spacepreserve = 1 if ((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/));
 508
 509     traverse($fh, $name, $cont, $language, $spacepreserve);
 510 }
 511
 512 # Verbatim copy from intltool-merge.in.in
 513 sub intltool_tree_comment
 514 {
 515     my $expat = shift;
 516     my $data  = $expat->original_string();
 517     my $clist = $expat->{Curlist};
 518     my $pos   = $#$clist;
 519
 520     $data =~ s/^<!--//s;
 521     $data =~ s/-->$//s;
 522     push @$clist, 1 => $data;
 523 }
 524
 525 # Verbatim copy from intltool-merge.in.in
 526 sub intltool_tree_cdatastart
 527 {
 528     my $expat    = shift;
 529     my $clist = $expat->{Curlist};
 530     my $pos   = $#$clist;
 531
 532     push @$clist, 0 => $expat->original_string();
 533 }
 534
 535 # Verbatim copy from intltool-merge.in.in
 536 sub intltool_tree_cdataend
 537 {
 538     my $expat    = shift;
 539     my $clist = $expat->{Curlist};
 540     my $pos   = $#$clist;
 541
 542     $clist->[$pos] .= $expat->original_string();
 543 }
 544
 545 # Verbatim copy from intltool-merge.in.in
 546 sub intltool_tree_char
 547 {
 548     my $expat = shift;
 549     my $text  = shift;
 550     my $clist = $expat->{Curlist};
 551     my $pos   = $#$clist;
 552
 553     # Use original_string so that we retain escaped entities
 554     # in CDATA sections.
 555     #
 556     if ($pos > 0 and $clist->[$pos - 1] eq '0') {
 557         $clist->[$pos] .= $expat->original_string();
 558     } else {
 559         push @$clist, 0 => $expat->original_string();
 560     }
 561 }
 562
 563 # Verbatim copy from intltool-merge.in.in
 564 sub intltool_tree_start
 565 {
 566     my $expat    = shift;
 567     my $tag      = shift;
 568     my @origlist = ();
 569
 570     # Use original_string so that we retain escaped entities
 571     # in attribute values.  We must convert the string to an
 572     # @origlist array to conform to the structure of the Tree
 573     # Style.
 574     #
 575     my @original_array = split /\x/, $expat->original_string();
 576     my $source         = $expat->original_string();
 577
 578     # Remove leading tag.
 579     #
 580     $source =~ s|^\s*<\s*(\S+)||s;
 581
 582     # Grab attribute key/value pairs and push onto @origlist array.
 583     #
 584     while ($source)
 585     {
 586        if ($source =~ /^\s*([\w:-]+)\s*[=]\s*["]/)
 587        {
 588            $source =~ s|^\s*([\w:-]+)\s*[=]\s*["]([^"]*)["]||s;
 589            push @origlist, $1;
 590            push @origlist, '"' . $2 . '"';
 591        }
 592        elsif ($source =~ /^\s*([\w:-]+)\s*[=]\s*[']/)
 593        {
 594            $source =~ s|^\s*([\w:-]+)\s*[=]\s*[']([^']*)[']||s;
 595            push @origlist, $1;
 596            push @origlist, "'" . $2 . "'";
 597        }
 598        else
 599        {
 600            last;
 601        }
 602     }
 603
 604     my $ol = [ { @origlist } ];
 605
 606     push @{ $expat->{Lists} }, $expat->{Curlist};
 607     push @{ $expat->{Curlist} }, $tag => $ol;
 608     $expat->{Curlist} = $ol;
 609 }
 610
 611 # Copied from intltool-merge.in.in and added comment handler.
 612 sub readXml
 613 {
 614     my $xmldoc = shift || return;
 615     my $ret = eval 'require XML::Parser';
 616     if(!$ret) {
 617         die "You must have XML::Parser installed to run $0\n\n";
 618     }
 619     my $xp = new XML::Parser(Style => 'Tree');
 620     $xp->setHandlers(Char => \&intltool_tree_char);
 621     $xp->setHandlers(Start => \&intltool_tree_start);
 622     $xp->setHandlers(CdataStart => \&intltool_tree_cdatastart);
 623     $xp->setHandlers(CdataEnd => \&intltool_tree_cdataend);
 624
 625     ## differences from intltool-merge.in.in
 626     $xp->setHandlers(Comment => \&intltool_tree_comment);
 627     ## differences end here from intltool-merge.in.in
 628
 629     my $tree = $xp->parse($xmldoc);
 630
 631 # <foo><!-- comment --><head id="a">Hello <em>there</em></head><bar>Howdy<ref/></bar>do</foo>
 632 # would be:
 633 # [foo, [{}, 1, "comment", head, [{id => "a"}, 0, "Hello ",  em, [{}, 0, "there"]], bar,
 634 # [{}, 0, "Howdy",  ref, [{}]], 0, "do" ] ]
 635
 636     return $tree;
 637 }
 638
 639 sub type_schemas {
 640     ### For schemas XML files ###
 641
 642     # FIXME: We should handle escaped < (less than)
 643     while ($input =~ /
 644                       <locale\ name="C">\s*
 645                           (<default>\s*(?:<!--([^>]*?)-->\s*)?(.*?)\s*<\/default>\s*)?
 646                           (<short>\s*(?:<!--([^>]*?)-->\s*)?(.*?)\s*<\/short>\s*)?
 647                           (<long>\s*(?:<!--([^>]*?)-->\s*)?(.*?)\s*<\/long>\s*)?
 648                       <\/locale>
 649                      /sgx) {
 650         my @totranslate = ($3,$6,$9);
 651         my @eachcomment = ($2,$5,$8);
 652         foreach (@totranslate) {
 653             my $currentcomment = shift @eachcomment;
 654             next if !$_;
 655             s/\s+/ /g;
 656             add_message(entity_decode_minimal($_));
 657             $comments{entity_decode_minimal($_)} = $currentcomment if (defined($currentcomment));
 658         }
 659     }
 660 }
 661
 662 # Parse the tree as returned by readXml() for gschema.xml files.
 663 sub traverse_gsettings {
 664     sub cleanup {
 665         s/^\s+//;
 666         s/\s+$//;
 667         s/\s+/ /g;
 668         return $_;
 669     }
 670
 671     my $nodename = shift;
 672     my $content = shift;
 673     my $comment = shift || 0;
 674     my @list = @{ $content };
 675     my $attrs_ref = shift @list;
 676     my %attrs = %{ $attrs_ref };
 677     if (($nodename eq 'default' and $attrs{'l10n'}) or
 678         ($nodename eq 'summary') or ($nodename eq 'description')) {
 679         # preserve whitespace.  deal with it ourselves, below.
 680         my $message = getXMLstring($content, 1);
 681
 682         if ($nodename eq 'default') {
 683             # for <default> we strip leading and trailing whitespace but
 684             # preserve (possibly quoted) whitespace within
 685             $message =~ s/^\s+//;
 686             $message =~ s/\s+$//;
 687         } else {
 688             # for <summary> and <description>, we normalise all
 689             # whitespace while preserving paragraph boundaries
 690             $message = join "\n\n", map &cleanup, split/\n\s*\n+/, $message;
 691         }
 692
 693         my $context = $attrs{'context'};
 694         $context =~ s/^["'](.*)["']/$1/ if $context;
 695         $message = $context . "\004" . $message if $context;
 696         add_message($message);
 697         $comments{$message} = $comment if $comment;
 698     } else {
 699         my $index = 0;
 700         my $comment;
 701         while (scalar(@list) > 1) {
 702             my $type = shift @list;
 703             my $content = shift @list;
 704             if (!$type || "$type" eq "1") {
 705                 if ($type == 1) {
 706                     $comment = $content;
 707                 }
 708                 next;
 709             } else {
 710                 traverse_gsettings($type, $content, $comment);
 711                 $comment = 0;
 712             }
 713         }
 714     }
 715 }
 716
 717 sub type_gsettings {
 718     my $tree = readXml($input);
 719     my @tree_nodes = @{ $tree };
 720     my $node = shift @tree_nodes;
 721     while (!$node || "$node" eq "1") {
 722         shift @tree_nodes;
 723         $node = shift @tree_nodes;
 724     }
 725     my $content = shift @tree_nodes;
 726     traverse_gsettings($node, $content);
 727 }
 728
 729 sub type_rfc822deb {
 730     ### For rfc822-style Debian configuration files ###
 731
 732     my $lineno = 1;
 733     my $type = '';
 734     while ($input =~ /\G(.*?)(^|\n)(_+)([^:]+):[ \t]*(.*?)(?=\n\S|$)/sg)
 735     {
 736         my ($pre, $newline, $underscore, $tag, $text) = ($1, $2, $3, $4, $5);
 737         while ($pre =~ m/\n/g)
 738         {
 739             $lineno ++;
 740         }
 741         $lineno += length($newline);
 742         my @str_list = rfc822deb_split(length($underscore), $text);
 743         for my $str (@str_list)
 744         {
 745             $strcount++;
 746             add_message($str);
 747             $loc{$str} = $lineno;
 748             $count{$str} = $strcount;
 749             my $usercomment = '';
 750             while($pre =~ s/(^|\n)#([^\n]*)$//s)
 751             {
 752                 $usercomment = "\n" . $2 . $usercomment;
 753             }
 754             $comments{$str} = $tag . $usercomment;
 755         }
 756         $lineno += ($text =~ s/\n//g);
 757     }
 758 }
 759
 760 sub rfc822deb_split {
 761     # Debian defines a special way to deal with rfc822-style files:
 762     # when a value contain newlines, it consists of
 763     #   1.  a short form (first line)
 764     #   2.  a long description, all lines begin with a space,
 765     #       and paragraphs are separated by a single dot on a line
 766     # This routine returns an array of all paragraphs, and reformat
 767     # them.
 768     # When first argument is 2, the string is a comma separated list of
 769     # values.
 770     my $type = shift;
 771     my $text = shift;
 772     $text =~ s/^[ \t]//mg;
 773     return (split(/, */, $text, 0)) if $type ne 1;
 774     return ($text) if $text !~ /\n/;
 775
 776     $text =~ s/([^\n]*)\n//;
 777     my @list = ($1);
 778     my $str = '';
 779     for my $line (split (/\n/, $text))
 780     {
 781         chomp $line;
 782         if ($line =~ /^\.\s*$/)
 783         {
 784             #  New paragraph
 785             $str =~ s/\s*$//;
 786             push(@list, $str);
 787             $str = '';
 788         }
 789         elsif ($line =~ /^\s/)
 790         {
 791             #  Line which must not be reformatted
 792             $str .= "\n" if length ($str) && $str !~ /\n$/;
 793             $line =~ s/\s+$//;
 794             $str .= $line."\n";
 795         }
 796         else
 797         {
 798             #  Continuation line, remove newline
 799             $str .= " " if length ($str) && $str !~ /\n$/;
 800             $str .= $line;
 801         }
 802     }
 803     $str =~ s/\s*$//;
 804     push(@list, $str) if length ($str);
 805     return @list;
 806 }
 807
 808 sub type_quoted {
 809     while ($input =~ /\"(([^\"]|\\\")*[^\\\"])\"/g) {
 810         my $message = $1;
 811         my $before = $`;
 812         $message =~ s/\\\"/\"/g;
 813         $before =~ s/[^\n]//g;
 814         add_message($message);
 815         $loc{$message} = length ($before) + 2;
 816     }
 817 }
 818
 819 sub type_quotedxml {
 820     while ($input =~ /\"(([^\"]|\\\")*[^\\\"])\"/g) {
 821         my $message = $1;
 822         my $before = $`;
 823         $message =~ s/\\\"/\"/g;
 824         $message = entity_decode($message);
 825         $before =~ s/[^\n]//g;
 826         add_message($message);
 827         $loc{$message} = length ($before) + 2;
 828     }
 829 }
 830
 831 sub type_glade {
 832     ### For translatable Glade XML files ###
 833
 834     my $tags = "label|title|text|format|copyright|comments|preview_text|tooltip|message";
 835
 836     while ($input =~ /<($tags)>([^<]+)<\/($tags)>/sg) {
 837         # Glade sometimes uses tags that normally mark translatable things for
 838         # little bits of non-translatable content. We work around this by not
 839         # translating strings that only includes something like label4 or window1.
 840         add_message(entity_decode($2)) unless $2 =~ /^(window|label|dialog)[0-9]+$/;
 841     }
 842
 843     while ($input =~ /<items>(..[^<]*)<\/items>/sg) {
 844         for my $item (split (/\n/, $1)) {
 845             add_message(entity_decode($item));
 846         }
 847     }
 848
 849     ## handle new glade files
 850     while ($input =~ /<(\w+)\s+[^>]*translatable\s*=\s*"yes"(?:\s+[^>]*context\s*=\s*"([^"]*)")?(?:\s+[^>]*comments\s*=\s*"([^"]*)")?[^>]*>([^<]+)<\/\1>/sg) {
 851         if (!($4 =~ /^(window|label)[0-9]+$/)) {
 852             my $message = entity_decode($4);
 853             if (defined($2)) {
 854                 $message = entity_decode($2) . "\004" . $message;
 855             }
 856             add_message($message);
 857             if (defined($3)) {
 858                 $comments{$message} = entity_decode($3) ;
 859             }
 860         }
 861     }
 862     while ($input =~ /<atkaction\s+action_name="([^>]*)"\s+description="([^>]+)"\/>/sg) {
 863         add_message(entity_decode_minimal($2));
 864     }
 865 }
 866
 867 sub type_tlk {
 868     my ($ftype, $fvers, $langid, $strcount, $stroff);
 869     my $count = 0;
 870     my $pos = 0;
 871     my @inputa = split (//, $input, 21);
 872     my $foo;
 873     my $strdata;
 874
 875     $ftype = substr ($input, 0, 3);
 876     $fvers = substr ($input, 4, 7);
 877     $langid = unpack ("L", $inputa[8] . $inputa[9] .
 878                       $inputa[10] . $inputa[11]);
 879     $strcount = unpack ("L", $inputa[12] . $inputa[13] .
 880                         $inputa[14] . $inputa[15]);
 881     $stroff = unpack ("L", $inputa[16] . $inputa[17] .
 882                       $inputa[18] . $inputa[19]);
 883
 884     use bytes;
 885     $strdata = bytes::substr ($input, $stroff);
 886
 887     my $sinpos = 20;
 888
 889     $foo = $inputa[$sinpos];
 890     $sinpos = 40 * 2000;
 891     @inputa = split (//, $foo, $sinpos + 1);
 892
 893     $pos = 0;
 894     while ($count < $strcount) {
 895         my ($flags, $soundref, $volvar, $pitch, $offset, $strsize, $sndlen) = 0;
 896
 897         if ($count > 0 && $count % 2000 == 0) {
 898             $foo = $inputa[$sinpos];
 899             my $numleft = ($strcount - $count);
 900             if ($numleft > 2000) {
 901                 $sinpos = 40 * 2000;
 902             } else {
 903                 $sinpos = 40 * $numleft;
 904             }
 905             @inputa = split (//, $foo, $sinpos + 1);
 906             my $numbytes = @inputa;
 907             $pos = 0;
 908         }
 909
 910
 911         $flags = unpack ("L", $inputa[$pos] . $inputa[$pos + 1] .
 912                          $inputa[$pos + 2] . $inputa[$pos + 3]);
 913         $pos += 4;
 914         if ($flags & 0x0002) {
 915             $soundref = join ('', @inputa[$pos..$pos + 15]);
 916             $soundref =~ s/\0//g;
 917         }
 918         $pos += 16;
 919 # According to the Bioware Aurora Talk Table Format documentation
 920 # the VolumeVariance and PitchVariance DWORDs are not used
 921 # We increment the pos counter, but do not read the data, here
 922 #        $volvar = unpack ("L", $inputa[$pos] . $inputa[$pos + 1] .
 923 #                          $inputa[$pos + 2] . $inputa[$pos + 3]);
 924         $pos += 4;
 925 #        $pitch = unpack ("L", $inputa[$pos] . $inputa[$pos + 1] .
 926 #                         $inputa[$pos + 2] . $inputa[$pos + 3]);
 927         $pos += 4;
 928         $offset = unpack ("L", $inputa[$pos] . $inputa[$pos + 1] .
 929                           $inputa[$pos + 2] . $inputa[$pos + 3])
 930             if ($flags & 0x0001);
 931         $pos += 4;
 932         $strsize = unpack ("L", $inputa[$pos] . $inputa[$pos + 1] .
 933                            $inputa[$pos + 2] . $inputa[$pos + 3])
 934             if ($flags & 0x0001);
 935         $pos += 4;
 936         $sndlen = unpack ("d", $inputa[$pos] . $inputa[$pos + 1] .
 937                           $inputa[$pos + 2] . $inputa[$pos + 3])
 938             if ($flags & 0x0004);
 939         $pos += 4;
 940
 941         if (defined $strsize && $strsize > 0) {
 942             my $message = substr ($strdata, $offset, $strsize);
 943             if (defined $message) {
 944                 use Encode;
 945                 Encode::from_to ($message, "iso-8859-1", "UTF-8");
 946                 add_message($message);
 947                 if ($message =~ /^Bad Strref$/ ) {
 948                     $comments{$message} = "DO NOT Translate this Entry.";
 949                     $comments{$message} .= "\nTLK:position=$count";
 950                } else {
 951                     $comments{$message} = "TLK:position=$count";
 952                     $comments{$message} .= "; TLK:sndresref=$soundref"
 953                         if (defined $soundref && $soundref ne "");
 954                     $comments{$message} .= "; TLK:sndlen=$sndlen"
 955                         if (defined $sndlen && $sndlen != 0);
 956                 }
 957             } else {
 958                 print STDERR "Missing message? ID: $count\n";
 959             }
 960         }
 961         $count++;
 962     }
 963 }
 964
 965 sub msg_write {
 966     my @msgids;
 967     if (%count)
 968     {
 969         @msgids = sort { $count{$a} <=> $count{$b} } keys %count;
 970     }
 971     else
 972     {
 973         @msgids = @messages_sorted;
 974     }
 975     for my $message (@msgids)
 976     {
 977         my $offsetlines = 1;
 978         my $context = undef;
 979         $offsetlines++ if $message =~ /%/;
 980         if (defined ($comments{$message}))
 981         {
 982                 while ($comments{$message} =~ m/\n/g)
 983                 {
 984                     $offsetlines++;
 985                 }
 986         }
 987         print OUT "# ".($loc{$message} - $offsetlines).  " \"$FILE\"\n"
 988                 if defined $loc{$message};
 989         print OUT "/* ".$comments{$message}." */\n"
 990                 if defined $comments{$message};
 991         print OUT "/* xgettext:no-c-format */\n" if $message =~ /%/;
 992
 993         if ($message =~ /(.*)\004(.*)/s) {
 994             $context = $1;
 995             $message = $2;
 996         }
 997         my @lines = split (/\n/, $message, -1);
 998         for (my $n = 0; $n < @lines; $n++)
 999         {
1000             if ($n == 0)
1001             {
1002                 if (defined $context)
1003                 {
1004                      if ($NOMSGCTXT_ARG)
1005                      {
1006                           print OUT "char *s = N_(\"", $context, "|";
1007                      }
1008                      else
1009                      {
1010                           print OUT "char *s = C_(\"", $context, "\", \"";
1011                      }
1012                 }
1013                 else
1014                 {
1015                      print OUT "char *s = N_(\"";
1016                 }
1017             }
1018             else
1019             {
1020                 print OUT "             \"";
1021             }
1022
1023             print OUT escape($lines[$n]);
1024
1025             if ($n < @lines - 1)
1026             {
1027                 print OUT "\\n\"\n";
1028             }
1029             else
1030             {
1031                 print OUT "\");\n";
1032             }
1033         }
1034     }
1035 }
1036