home *** CD-ROM | disk | FTP | other *** search
/ Chip 2007 November / CPNL0711.ISO / communic / email / Evolution-2.8.2-2.msi / Data1.cab / intltool_extract.in < prev    next >
Text File  |  2007-03-07  |  23KB  |  862 lines
  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      = "intltool";
  35. my $VERSION      = "0.35.5";
  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.  
  51. my $FILE;
  52. my $OUTFILE;
  53.  
  54. my $gettext_type = "";
  55. my $input;
  56. my %messages = ();
  57. my %loc = ();
  58. my %count = ();
  59. my %comments = ();
  60. my $strcount = 0;
  61.  
  62. my $XMLCOMMENT = "";
  63.  
  64. ## Use this instead of \w for XML files to handle more possible characters.
  65. my $w = "[-A-Za-z0-9._:]";
  66.  
  67. ## Always print first
  68. $| = 1;
  69.  
  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;
  80.  
  81. &split_on_argument;
  82.  
  83.  
  84. ## Check for options. 
  85. ## This section will check for the different options.
  86.  
  87. sub 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.  
  114. sub 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.  
  124. sub 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.  
  133. sub determine_type {
  134.    if ($TYPE_ARG =~ /^gettext\/(.*)/) {
  135.     $gettext_type=$1
  136.    }
  137. }
  138.  
  139. ## Sub for printing release information
  140. sub version{
  141.     print <<_EOF_;
  142. ${PROGRAM} (${PACKAGE}) $VERSION
  143. Copyright (C) 2000, 2003 Free Software Foundation, Inc.
  144. Written by Kenneth Christiansen, 2000.
  145.  
  146. This is free software; see the source for copying conditions.  There is NO
  147. warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  148. _EOF_
  149.     exit;
  150. }
  151.  
  152. ## Sub for printing usage information
  153. sub help {
  154.     print <<_EOF_;
  155. Usage: ${PROGRAM} [OPTION]... [FILENAME]
  156. Generates a header file from an XML source file.
  157.  
  158. It grabs all strings between <_translatable_node> and its end tag in
  159. XML 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.  
  174. Report bugs to http://bugzilla.gnome.org/ (product name "$PACKAGE")
  175. or send email to <xml-i18n-tools\@gnome.org>.
  176. _EOF_
  177.     exit;
  178. }
  179.  
  180. ## Sub for printing error messages
  181. sub error{
  182.     print STDERR "Try `${PROGRAM} --help' for more information.\n";
  183.     exit;
  184. }
  185.  
  186. sub message {
  187.     print "Generating C format header file for translation.\n" unless $QUIET_ARG;
  188. }
  189.  
  190. sub 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.  
  203. sub 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.  
  223. sub entity_decode_minimal
  224. {
  225.     local ($_) = @_;
  226.  
  227.     s/'/'/g; # '
  228.     s/"/"/g; # "
  229.     s/&/&/g;
  230.  
  231.     return $_;
  232. }
  233.  
  234. sub 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.  
  247. sub escape_char
  248. {
  249.     return '\"' if $_ eq '"';
  250.     return '\n' if $_ eq "\n";
  251.     return '\\\\' if $_ eq '\\';
  252.  
  253.     return $_;
  254. }
  255.  
  256. sub escape
  257. {
  258.     my ($string) = @_;
  259.     return join "", map &escape_char, split //, $string;
  260. }
  261.  
  262. sub 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.  
  272. sub type_keys {
  273.     ### For generic translatable mime/keys files ###
  274.     while ($input =~ /^\s*_\w+=(.*)$/mg) {
  275.         $messages{$1} = [];
  276.     }
  277. }
  278.  
  279. sub type_xml {
  280.     ### For generic translatable XML files ###
  281.     my $tree = readXml($input);
  282.     parseTree(0, $tree);
  283. }
  284.  
  285. sub 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)
  312. sub 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
  347. sub 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
  393. sub 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
  414. sub 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
  472. sub 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
  494. sub 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
  507. sub 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
  517. sub 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
  527. sub 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
  545. sub 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.
  593. sub 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.  
  621. sub 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.  
  644. sub 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.  
  675. sub 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.  
  723. sub 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.  
  734. sub 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.  
  764. sub 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.  
  809. sub 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.