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