开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Linux/Unix编程 > 驱动编程 > 查看源码
intltool-extract.in
资源名称：fmradio.zip　[点击查看]
上传用户：ledjyj
上传日期：2014-08-27
资源大小：2639k
文件大小：22k
源码类别：

驱动编程

开发平台：

Unix_Linux

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