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