source: trunk/third/gpdf/intltool-merge.in @ 21437

Revision 21437, 31.0 KB checked in by ghudson, 20 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r21436, which included commits to RCS files with non-trunk default branches.
Line 
1#!@INTLTOOL_PERL@ -w
2# -*- Mode: perl; indent-tabs-mode: nil; c-basic-offset: 4  -*-
3
4#
5#  The Intltool Message Merger
6#
7#  Copyright (C) 2000, 2003 Free Software Foundation.
8#  Copyright (C) 2000, 2001 Eazel, Inc
9#
10#  Intltool is free software; you can redistribute it and/or
11#  modify it under the terms of the GNU General Public License
12#  version 2 published by the Free Software Foundation.
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:  Maciej Stachowiak <mjs@noisehavoc.org>
29#            Kenneth Christiansen <kenneth@gnu.org>
30#            Darin Adler <darin@bentspoon.com>
31#
32#  Proper XML UTF-8'ification written by Cyrille Chepelov <chepelov@calixo.net>
33#
34
35## Release information
36my $PROGRAM = "intltool-merge";
37my $PACKAGE = "intltool";
38my $VERSION = "0.32.1";
39
40## Loaded modules
41use strict;
42use Getopt::Long;
43use Text::Wrap;
44use File::Basename;
45
46my $must_end_tag      = -1;
47my $last_depth        = -1;
48my $translation_depth = -1;
49my @tag_stack = ();
50my @entered_tag = ();
51my @translation_strings = ();
52my $leading_space = "";
53
54## Scalars used by the option stuff
55my $HELP_ARG = 0;
56my $VERSION_ARG = 0;
57my $BA_STYLE_ARG = 0;
58my $XML_STYLE_ARG = 0;
59my $KEYS_STYLE_ARG = 0;
60my $DESKTOP_STYLE_ARG = 0;
61my $SCHEMAS_STYLE_ARG = 0;
62my $RFC822DEB_STYLE_ARG = 0;
63my $QUIET_ARG = 0;
64my $PASS_THROUGH_ARG = 0;
65my $UTF8_ARG = 0;
66my $MULTIPLE_OUTPUT = 0;
67my $cache_file;
68
69## Handle options
70GetOptions
71(
72 "help" => \$HELP_ARG,
73 "version" => \$VERSION_ARG,
74 "quiet|q" => \$QUIET_ARG,
75 "oaf-style|o" => \$BA_STYLE_ARG, ## for compatibility
76 "ba-style|b" => \$BA_STYLE_ARG,
77 "xml-style|x" => \$XML_STYLE_ARG,
78 "keys-style|k" => \$KEYS_STYLE_ARG,
79 "desktop-style|d" => \$DESKTOP_STYLE_ARG,
80 "schemas-style|s" => \$SCHEMAS_STYLE_ARG,
81 "rfc822deb-style|r" => \$RFC822DEB_STYLE_ARG,
82 "pass-through|p" => \$PASS_THROUGH_ARG,
83 "utf8|u" => \$UTF8_ARG,
84 "multiple-output|m" => \$MULTIPLE_OUTPUT,
85 "cache|c=s" => \$cache_file
86 ) or &error;
87
88my $PO_DIR;
89my $FILE;
90my $OUTFILE;
91
92my %po_files_by_lang = ();
93my %translations = ();
94my $iconv = $ENV{"ICONV"} || $ENV{"INTLTOOL_ICONV"} || "@INTLTOOL_ICONV@";
95
96# Use this instead of \w for XML files to handle more possible characters.
97my $w = "[-A-Za-z0-9._:]";
98
99# XML quoted string contents
100my $q = "[^\\\"]*";
101
102## Check for options.
103
104if ($VERSION_ARG)
105{
106        &print_version;
107}
108elsif ($HELP_ARG)
109{
110        &print_help;
111}
112elsif ($BA_STYLE_ARG && @ARGV > 2)
113{
114        &utf8_sanity_check;
115        &preparation;
116        &print_message;
117        &ba_merge_translations;
118        &finalize;
119}
120elsif ($XML_STYLE_ARG && @ARGV > 2)
121{
122        &utf8_sanity_check;
123        &preparation;
124        &print_message;
125        &xml_merge_output;
126        &finalize;
127}
128elsif ($KEYS_STYLE_ARG && @ARGV > 2)
129{
130        &utf8_sanity_check;
131        &preparation;
132        &print_message;
133        &keys_merge_translations;
134        &finalize;
135}
136elsif ($DESKTOP_STYLE_ARG && @ARGV > 2)
137{
138        &utf8_sanity_check;
139        &preparation;
140        &print_message;
141        &desktop_merge_translations;
142        &finalize;
143}
144elsif ($SCHEMAS_STYLE_ARG && @ARGV > 2)
145{
146        &utf8_sanity_check;
147        &preparation;
148        &print_message;
149        &schemas_merge_translations;
150        &finalize;
151}
152elsif ($RFC822DEB_STYLE_ARG && @ARGV > 2)
153{
154        &preparation;
155        &print_message;
156        &rfc822deb_merge_translations;
157        &finalize;
158}
159else
160{
161        &print_help;
162}
163
164exit;
165
166## Sub for printing release information
167sub print_version
168{
169    print <<_EOF_;
170${PROGRAM} (${PACKAGE}) ${VERSION}
171Written by Maciej Stachowiak, Darin Adler and Kenneth Christiansen.
172
173Copyright (C) 2000-2003 Free Software Foundation, Inc.
174Copyright (C) 2000-2001 Eazel, Inc.
175This is free software; see the source for copying conditions.  There is NO
176warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
177_EOF_
178    exit;
179}
180
181## Sub for printing usage information
182sub print_help
183{
184    print <<_EOF_;
185Usage: ${PROGRAM} [OPTION]... PO_DIRECTORY FILENAME OUTPUT_FILE
186Generates an output file that includes some localized attributes from an
187untranslated source file.
188
189Mandatory options: (exactly one must be specified)
190  -b, --ba-style         includes translations in the bonobo-activation style
191  -d, --desktop-style    includes translations in the desktop style
192  -k, --keys-style       includes translations in the keys style
193  -s, --schemas-style    includes translations in the schemas style
194  -r, --rfc822deb-style  includes translations in the RFC822 style
195  -x, --xml-style        includes translations in the standard xml style
196
197Other options:
198  -u, --utf8             convert all strings to UTF-8 before merging
199                         (default for everything except RFC822 style)
200  -p, --pass-through     deprecated, does nothing and issues a warning
201  -m, --multiple-output  output one localized file per locale, instead of
202                         a single file containing all localized elements
203  -c, --cache=FILE       specify cache file name
204                         (usually \$top_builddir/po/.intltool-merge-cache)
205  -q, --quiet            suppress most messages
206      --help             display this help and exit
207      --version          output version information and exit
208
209Report bugs to http://bugzilla.gnome.org/ (product name "$PACKAGE")
210or send email to <xml-i18n-tools\@gnome.org>.
211_EOF_
212    exit;
213}
214
215
216## Sub for printing error messages
217sub print_error
218{
219    print STDERR "Try `${PROGRAM} --help' for more information.\n";
220    exit;
221}
222
223
224sub print_message
225{
226    print "Merging translations into $OUTFILE.\n" unless $QUIET_ARG;
227}
228
229
230sub preparation
231{
232    $PO_DIR = $ARGV[0];
233    $FILE = $ARGV[1];
234    $OUTFILE = $ARGV[2];
235
236    &gather_po_files;
237    &get_translation_database;
238}
239
240# General-purpose code for looking up translations in .po files
241
242sub po_file2lang
243{
244    my ($tmp) = @_;
245    $tmp =~ s/^.*\/(.*)\.po$/$1/;
246    return $tmp;
247}
248
249sub gather_po_files
250{
251    for my $po_file (glob "$PO_DIR/*.po") {
252        $po_files_by_lang{po_file2lang($po_file)} = $po_file;
253    }
254}
255
256sub get_local_charset
257{
258    my ($encoding) = @_;
259    my $alias_file = $ENV{"G_CHARSET_ALIAS"} || "/usr/lib/charset.alias";
260
261    # seek character encoding aliases in charset.alias (glib)
262
263    if (open CHARSET_ALIAS, $alias_file)
264    {
265        while (<CHARSET_ALIAS>)
266        {
267            next if /^\#/;
268            return $1 if (/^\s*([-._a-zA-Z0-9]+)\s+$encoding\b/i)
269        }
270
271        close CHARSET_ALIAS;
272    }
273
274    # if not found, return input string
275
276    return $encoding;
277}
278
279sub get_po_encoding
280{
281    my ($in_po_file) = @_;
282    my $encoding = "";
283
284    open IN_PO_FILE, $in_po_file or die;
285    while (<IN_PO_FILE>)
286    {
287        ## example: "Content-Type: text/plain; charset=ISO-8859-1\n"
288        if (/Content-Type\:.*charset=([-a-zA-Z0-9]+)\\n/)
289        {
290            $encoding = $1;
291            last;
292        }
293    }
294    close IN_PO_FILE;
295
296    if (!$encoding)
297    {
298        print STDERR "Warning: no encoding found in $in_po_file. Assuming ISO-8859-1\n" unless $QUIET_ARG;
299        $encoding = "ISO-8859-1";
300    }
301
302    system ("$iconv -f $encoding -t UTF-8 </dev/null 2>/dev/null");
303    if ($?) {
304        $encoding = get_local_charset($encoding);
305    }
306
307    return $encoding
308}
309
310sub utf8_sanity_check
311{
312    print STDERR "Warning: option --pass-through has been removed.\n" if $PASS_THROUGH_ARG;
313    $UTF8_ARG = 1;
314}
315
316sub get_translation_database
317{
318    if ($cache_file) {
319        &get_cached_translation_database;
320    } else {
321        &create_translation_database;
322    }
323}
324
325sub get_newest_po_age
326{
327    my $newest_age;
328
329    foreach my $file (values %po_files_by_lang)
330    {
331        my $file_age = -M $file;
332        $newest_age = $file_age if !$newest_age || $file_age < $newest_age;
333    }
334
335    $newest_age = 0 if !$newest_age;
336
337    return $newest_age;
338}
339
340sub create_cache
341{
342    print "Generating and caching the translation database\n" unless $QUIET_ARG;
343
344    &create_translation_database;
345
346    open CACHE, ">$cache_file" || die;
347    print CACHE join "\x01", %translations;
348    close CACHE;
349}
350
351sub load_cache
352{
353    print "Found cached translation database\n" unless $QUIET_ARG;
354
355    my $contents;
356    open CACHE, "<$cache_file" || die;
357    {
358        local $/;
359        $contents = <CACHE>;
360    }
361    close CACHE;
362    %translations = split "\x01", $contents;
363}
364
365sub get_cached_translation_database
366{
367    my $cache_file_age = -M $cache_file;
368    if (defined $cache_file_age)
369    {
370        if ($cache_file_age <= &get_newest_po_age)
371        {
372            &load_cache;
373            return;
374        }
375        print "Found too-old cached translation database\n" unless $QUIET_ARG;
376    }
377
378    &create_cache;
379}
380
381sub create_translation_database
382{
383    for my $lang (keys %po_files_by_lang)
384    {
385        my $po_file = $po_files_by_lang{$lang};
386
387        if ($UTF8_ARG)
388        {
389            my $encoding = get_po_encoding ($po_file);
390
391            if (lc $encoding eq "utf-8")
392            {
393                open PO_FILE, "<$po_file";     
394            }
395            else
396            {
397                print STDERR "WARNING: $po_file is not in UTF-8 but $encoding, converting...\n" unless $QUIET_ARG;;
398
399                open PO_FILE, "$iconv -f $encoding -t UTF-8 $po_file|";
400            }
401        }
402        else
403        {
404            open PO_FILE, "<$po_file"; 
405        }
406
407        my $nextfuzzy = 0;
408        my $inmsgid = 0;
409        my $inmsgstr = 0;
410        my $msgid = "";
411        my $msgstr = "";
412
413        while (<PO_FILE>)
414        {
415            $nextfuzzy = 1 if /^#, fuzzy/;
416       
417            if (/^msgid "((\\.|[^\\])*)"/ )
418            {
419                $translations{$lang, $msgid} = $msgstr if $inmsgstr && $msgid && $msgstr;
420                $msgid = "";
421                $msgstr = "";
422
423                if ($nextfuzzy) {
424                    $inmsgid = 0;
425                } else {
426                    $msgid = unescape_po_string($1);
427                    $inmsgid = 1;
428                }
429                $inmsgstr = 0;
430                $nextfuzzy = 0;
431            }
432
433            if (/^msgstr "((\\.|[^\\])*)"/)
434            {
435                $msgstr = unescape_po_string($1);
436                $inmsgstr = 1;
437                $inmsgid = 0;
438            }
439
440            if (/^"((\\.|[^\\])*)"/)
441            {
442                $msgid .= unescape_po_string($1) if $inmsgid;
443                $msgstr .= unescape_po_string($1) if $inmsgstr;
444            }
445        }
446        $translations{$lang, $msgid} = $msgstr if $inmsgstr && $msgid && $msgstr;
447    }
448}
449
450sub finalize
451{
452}
453
454sub unescape_one_sequence
455{
456    my ($sequence) = @_;
457
458    return "\\" if $sequence eq "\\\\";
459    return "\"" if $sequence eq "\\\"";
460    return "\n" if $sequence eq "\\n";
461    return "\r" if $sequence eq "\\r";
462    return "\t" if $sequence eq "\\t";
463    return "\b" if $sequence eq "\\b";
464    return "\f" if $sequence eq "\\f";
465    return "\a" if $sequence eq "\\a";
466    return chr(11) if $sequence eq "\\v"; # vertical tab, see ascii(7)
467
468    return chr(hex($1)) if ($sequence =~ /\\x([0-9a-fA-F]{2})/);
469    return chr(oct($1)) if ($sequence =~ /\\([0-7]{3})/);
470
471    # FIXME: Is \0 supported as well? Kenneth and Rodney don't want it, see bug #48489
472
473    return $sequence;
474}
475
476sub unescape_po_string
477{
478    my ($string) = @_;
479
480    $string =~ s/(\\x[0-9a-fA-F]{2}|\\[0-7]{3}|\\.)/unescape_one_sequence($1)/eg;
481
482    return $string;
483}
484
485## NOTE: deal with < - &lt; but not > - &gt;  because it seems its ok to have
486## > in the entity. For further info please look at #84738.
487sub entity_decode
488{
489    local ($_) = @_;
490
491    s/&apos;/'/g; # '
492    s/&quot;/"/g; # "
493    s/&amp;/&/g;
494    s/&lt;/</g;
495
496    return $_;
497}
498 
499# entity_encode: (string)
500#
501# Encode the given string to XML format (encode '<' etc).
502
503sub entity_encode
504{
505    my ($pre_encoded) = @_;
506
507    my @list_of_chars = unpack ('C*', $pre_encoded);
508
509    # with UTF-8 we only encode minimalistic
510    return join ('', map (&entity_encode_int_minimalist, @list_of_chars));
511}
512
513sub entity_encode_int_minimalist
514{
515    return "&quot;" if $_ == 34;
516    return "&amp;" if $_ == 38;
517    return "&apos;" if $_ == 39;
518    return "&lt;" if $_ == 60;
519    return chr $_;
520}
521
522sub entity_encoded_translation
523{
524    my ($lang, $string) = @_;
525
526    my $translation = $translations{$lang, $string};
527    return $string if !$translation;
528    return entity_encode ($translation);
529}
530
531## XML (bonobo-activation specific) merge code
532
533sub ba_merge_translations
534{
535    my $source;
536
537    {
538       local $/; # slurp mode
539       open INPUT, "<$FILE" or die "can't open $FILE: $!";
540       $source = <INPUT>;
541       close INPUT;
542    }
543
544    open OUTPUT, ">$OUTFILE" or die "can't open $OUTFILE: $!";
545
546    while ($source =~ s|^(.*?)([ \t]*<\s*$w+\s+($w+\s*=\s*"$q"\s*)+/?>)([ \t]*\n)?||s)
547    {
548        print OUTPUT $1;
549
550        my $node = $2 . "\n";
551
552        my @strings = ();
553        $_ = $node;
554        while (s/(\s)_($w+\s*=\s*"($q)")/$1$2/s) {
555             push @strings, entity_decode($3);
556        }
557        print OUTPUT;
558
559        my %langs;
560        for my $string (@strings)
561        {
562            for my $lang (keys %po_files_by_lang)
563            {
564                $langs{$lang} = 1 if $translations{$lang, $string};
565            }
566        }
567       
568        for my $lang (sort keys %langs)
569        {
570            $_ = $node;
571            s/(\sname\s*=\s*)"($q)"/$1"$2-$lang"/s;
572            s/(\s)_($w+\s*=\s*")($q)"/$1 . $2 . entity_encoded_translation($lang, $3) . '"'/seg;
573            print OUTPUT;
574        }
575    }
576
577    print OUTPUT $source;
578
579    close OUTPUT;
580}
581
582
583## XML (non-bonobo-activation) merge code
584
585
586# Process tag attributes
587#   Only parameter is a HASH containing attributes -> values mapping
588sub getAttributeString
589{
590    my $sub = shift;
591    my $do_translate = shift || 0;
592    my $language = shift || "";
593    my $result = "";
594    my $translate = shift;
595    foreach my $e (reverse(sort(keys %{ $sub }))) {
596        my $key    = $e;
597        my $string = $sub->{$e};
598        my $quote = '"';
599       
600        $string =~ s/^[\s]+//;
601        $string =~ s/[\s]+$//;
602       
603        if ($string =~ /^'.*'$/)
604        {
605            $quote = "'";
606        }
607        $string =~ s/^['"]//g;
608        $string =~ s/['"]$//g;
609
610        if ($do_translate && $key =~ /^_/) {
611            $key =~ s|^_||g;
612            if ($language) {
613               
614                # Handle translation
615                #
616                my $decode_string = entity_decode($string);
617                my $translation = $translations{$language, $decode_string};
618                if ($translation) {
619                    $translation = entity_encode($translation);
620                    $string = $translation;
621                    $$translate = 2;
622                }
623            } else {
624                 $$translate = 1 if ($translate && (!$$translate)); # watch not to "overwrite" if $translate == 2
625            }
626        }
627       
628        $result .= " $key=$quote$string$quote";
629    }
630    return $result;
631}
632
633# Returns a translatable string from XML node, it works on contents of every node in XML::Parser tree
634#   doesn't support nesting of translatable tags (i.e. <_blah>this <_doh>doesn't</_doh> work</_blah> -- besides
635#   can you define the correct semantics for this?)
636#
637
638sub getXMLstring
639{
640    my $ref = shift;
641    my @list = @{ $ref };
642    my $result = "";
643
644    my $count = scalar(@list);
645    my $attrs = $list[0];
646    my $index = 1;
647
648    while ($index < $count) {
649        my $type = $list[$index];
650        my $content = $list[$index+1];
651        if (! $type ) {
652            # We've got CDATA
653            if ($content) {
654                # lets strip the whitespace here, and *ONLY* here
655                $content =~ s/\s+/ /gs if (!((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/)));
656                $result .= ($content);
657            } else {
658                #print "no cdata content when expected it\n"; # is this possible, is this ok?
659                # what to do if this happens?
660                # Did I mention that I hate XML::Parser tree style?
661            }
662        } else {
663            # We've got another element
664            $result .= "<$type";
665            $result .= getAttributeString(@{$content}[0], 0); # no nested translatable elements
666            if ($content) {
667                my $subresult = getXMLstring($content);
668                if ($subresult) {
669                    $result .= ">".$subresult . "</$type>";
670                } else {
671                    $result .= "/>";
672                }
673            } else {
674                $result .= "/>";
675            }
676        }
677        $index += 2;
678    }
679    return $result;
680}
681
682sub traverse
683{
684    my $fh = shift;
685    my $nodename = shift;
686    my $content = shift;
687    my $language = shift || "";
688
689    if (!$nodename) {
690        if ($content =~ /^[\s]*$/) {
691            $leading_space .= $content;
692        }
693        print $fh $content;
694    } else {
695        # element
696        my @all = @{ $content };
697        my $attrs = shift @all;
698        my $translate = 0;
699        my $outattr = getAttributeString($attrs, 1, $language, \$translate);
700
701        if ($nodename =~ /^_/) {
702            $translate = 1;
703            $nodename =~ s/^_//;
704        }
705        my $lookup = '';
706        print $fh "<$nodename", $outattr;
707        if ($translate) {
708            $lookup = getXMLstring($content);
709            if (!((exists $attrs->{"xml:space"}) && ($attrs->{"xml:space"} =~ /^["']?preserve["']?$/))) {
710                $lookup =~ s/^\s+//s;
711                $lookup =~ s/\s+$//s;
712            }
713
714            if ($lookup || $translate == 2) {
715                my $translation = $translations{$language, $lookup};
716                if ($MULTIPLE_OUTPUT && ($translation || $translate == 2)) {
717                    $translation = $lookup if (!$translation);
718                    print $fh " xml:lang=\"", $language, "\"";
719                    print $fh ">", $translation, "</$nodename>";
720                    return; # this means there will be no same translation with xml:lang="$language"...
721                            # if we want them both, just remove this "return"
722                } else {
723                    print $fh ">$lookup</$nodename>";
724                }
725            } else {
726                print $fh "/>";
727            }
728
729            for my $lang (sort keys %po_files_by_lang) {
730                    if ($MULTIPLE_OUTPUT && $lang ne "$language") {
731                        next;
732                    }
733                    if ($lang) {
734                        # Handle translation
735                        #
736                        my $translate = 0;
737                        my $localattrs = getAttributeString($attrs, 1, $lang, \$translate);
738                        my $translation = $translations{$lang, $lookup};
739                        if ($translate && !$translation) {
740                            $translation = $lookup;
741                        }
742
743                        if ($translation || $translate) {
744                            $translation = ($translation);
745                            print $fh "\n";
746                            $leading_space =~ s/.*\n//g;
747                            print $fh $leading_space;
748                            print $fh "<", $nodename, " xml:lang=\"", $lang, "\"", $localattrs;
749                            print $fh ">", $translation , "</$nodename>";
750                        }
751                    }
752            }
753
754        } else {
755            my $count = scalar(@all);
756            if ($count > 0) {
757                print $fh ">";
758            } else {
759                print $fh "/>";
760            }
761            my $index = 0;
762            while ($index < $count) {
763                my $type = $all[$index];
764                my $rest = $all[$index+1];
765                traverse($fh, $type, $rest, $language);
766                $index += 2;
767            }
768            if ($count > 0) {
769                print $fh "</$nodename>";
770            }
771        }
772    }
773}
774
775sub intltool_tree_char
776{
777    my $expat = shift;
778    my $text  = shift;
779    my $clist = $expat->{Curlist};
780    my $pos   = $#$clist;
781
782    # Use original_string so that we retain escaped entities
783    # in CDATA sections.
784    #
785    if ($pos > 0 and $clist->[$pos - 1] eq '0') {
786        $clist->[$pos] .= $expat->original_string();
787    } else {
788        push @$clist, 0 => $expat->original_string();
789    }
790}
791
792sub intltool_tree_start
793{
794    my $expat    = shift;
795    my $tag      = shift;
796    my @origlist = ();
797
798    # Use original_string so that we retain escaped entities
799    # in attribute values.  We must convert the string to an
800    # @origlist array to conform to the structure of the Tree
801    # Style.
802    #
803    my @original_array = split /\x/, $expat->original_string();
804    my $source         = $expat->original_string();
805
806    # Remove leading tag.
807    #
808    $source =~ s|^\s*<\s*(\S+)||s;
809
810    # Grab attribute key/value pairs and push onto @origlist array.
811    #
812    while ($source)
813    {
814       if ($source =~ /^\s*([\w:-]+)\s*[=]\s*["]/)
815       {
816           $source =~ s|^\s*([\w:-]+)\s*[=]\s*["]([^"]*)["]||s;
817           push @origlist, $1;
818           push @origlist, '"' . $2 . '"';
819       }
820       elsif ($source =~ /^\s*([\w:-]+)\s*[=]\s*[']/)
821       {
822           $source =~ s|^\s*([\w:-]+)\s*[=]\s*[']([^']*)[']||s;
823           push @origlist, $1;
824           push @origlist, "'" . $2 . "'";
825       }
826       else
827       {
828           last;
829       }
830    }
831
832    my $ol = [ { @origlist } ];
833
834    push @{ $expat->{Lists} }, $expat->{Curlist};
835    push @{ $expat->{Curlist} }, $tag => $ol;
836    $expat->{Curlist} = $ol;
837}
838
839sub readXml
840{
841    my $filename = shift || return;
842    if(!-f $filename) {
843        die "ERROR Cannot find filename: $filename\n";
844    }
845
846    my $ret = eval 'require XML::Parser';
847    if(!$ret) {
848        die "You must have XML::Parser installed to run $0\n\n";
849    }
850    my $xp = new XML::Parser(Style => 'Tree');
851    $xp->setHandlers(Char => \&intltool_tree_char);
852    $xp->setHandlers(Start => \&intltool_tree_start);
853    my $tree = $xp->parsefile($filename);
854
855# <foo><head id="a">Hello <em>there</em></head><bar>Howdy<ref/></bar>do</foo>
856# would be:
857# [foo, [{}, head, [{id => "a"}, 0, "Hello ",  em, [{}, 0, "there"]], bar, [{},
858# 0, "Howdy",  ref, [{}]], 0, "do" ] ]
859
860    return $tree;
861}
862
863sub print_header
864{
865    my $infile = shift;
866    my $fh = shift;
867    my $source;
868
869    if(!-f $infile) {
870        die "ERROR Cannot find filename: $infile\n";
871    }
872
873    print $fh qq{<?xml version="1.0" encoding="UTF-8"?>\n};
874    {
875        local $/;
876        open DOCINPUT, "<${FILE}" or die;
877        $source = <DOCINPUT>;
878        close DOCINPUT;
879    }
880    if ($source =~ /(<!DOCTYPE.*\[.*\]\s*>)/s)
881    {
882        print $fh "$1\n";
883    }
884    elsif ($source =~ /(<!DOCTYPE[^>]*>)/s)
885    {
886        print $fh "$1\n";
887    }
888}
889
890sub parseTree
891{
892    my $fh        = shift;
893    my $ref       = shift;
894    my $language  = shift || "";
895
896    my $name = shift @{ $ref };
897    my $cont = shift @{ $ref };
898    traverse($fh, $name, $cont, $language);
899}
900
901sub xml_merge_output
902{
903    my $source;
904
905    if ($MULTIPLE_OUTPUT) {
906        for my $lang (sort keys %po_files_by_lang) {
907            if ( ! -e $lang ) {
908                mkdir $lang or die "Cannot create subdirectory $lang: $!\n";
909            }
910            open OUTPUT, ">$lang/$OUTFILE" or die "Cannot open $lang/$OUTFILE: $!\n";
911            my $tree = readXml($FILE);
912            print_header($FILE, \*OUTPUT);
913            parseTree(\*OUTPUT, $tree, $lang);
914            close OUTPUT;
915            print "CREATED $lang/$OUTFILE\n" unless $QUIET_ARG;
916        }
917    }
918    open OUTPUT, ">$OUTFILE" or die "Cannot open $OUTFILE: $!\n";
919    my $tree = readXml($FILE);
920    print_header($FILE, \*OUTPUT);
921    parseTree(\*OUTPUT, $tree);
922    close OUTPUT;
923    print "CREATED $OUTFILE\n" unless $QUIET_ARG;
924}
925
926sub keys_merge_translations
927{
928    open INPUT, "<${FILE}" or die;
929    open OUTPUT, ">${OUTFILE}" or die;
930
931    while (<INPUT>)
932    {
933        if (s/^(\s*)_(\w+=(.*))/$1$2/) 
934        {
935            my $string = $3;
936
937            print OUTPUT;
938
939            my $non_translated_line = $_;
940
941            for my $lang (sort keys %po_files_by_lang)
942            {
943                my $translation = $translations{$lang, $string};
944                next if !$translation;
945
946                $_ = $non_translated_line;
947                s/(\w+)=.*/[$lang]$1=$translation/;
948                print OUTPUT;
949            }
950        }
951        else
952        {
953            print OUTPUT;
954        }
955    }
956
957    close OUTPUT;
958    close INPUT;
959}
960
961sub desktop_merge_translations
962{
963    open INPUT, "<${FILE}" or die;
964    open OUTPUT, ">${OUTFILE}" or die;
965
966    while (<INPUT>)
967    {
968        if (s/^(\s*)_(\w+=(.*))/$1$2/) 
969        {
970            my $string = $3;
971
972            print OUTPUT;
973
974            my $non_translated_line = $_;
975
976            for my $lang (sort keys %po_files_by_lang)
977            {
978                my $translation = $translations{$lang, $string};
979                next if !$translation;
980
981                $_ = $non_translated_line;
982                s/(\w+)=.*/${1}[$lang]=$translation/;
983                print OUTPUT;
984            }
985        }
986        else
987        {
988            print OUTPUT;
989        }
990    }
991
992    close OUTPUT;
993    close INPUT;
994}
995
996sub schemas_merge_translations
997{
998    my $source;
999
1000    {
1001       local $/; # slurp mode
1002       open INPUT, "<$FILE" or die "can't open $FILE: $!";
1003       $source = <INPUT>;
1004       close INPUT;
1005    }
1006
1007    open OUTPUT, ">$OUTFILE" or die;
1008
1009    # FIXME: support attribute translations
1010
1011    # Empty nodes never need translation, so unmark all of them.
1012    # For example, <_foo/> is just replaced by <foo/>.
1013    $source =~ s|<\s*_($w+)\s*/>|<$1/>|g;
1014
1015    while ($source =~ s/
1016                        (.*?)
1017                        (\s+)(<locale\ name="C">(\s*)
1018                            (<default>\s*(?:<!--[^>]*?-->\s*)?(.*?)\s*<\/default>)?(\s*)
1019                            (<short>\s*(?:<!--[^>]*?-->\s*)?(.*?)\s*<\/short>)?(\s*)
1020                            (<long>\s*(?:<!--[^>]*?-->\s*)?(.*?)\s*<\/long>)?(\s*)
1021                        <\/locale>)
1022                       //sx)
1023    {
1024        print OUTPUT $1;
1025
1026        my $locale_start_spaces = $2 ? $2 : '';
1027        my $default_spaces = $4 ? $4 : '';
1028        my $short_spaces = $7 ? $7 : '';
1029        my $long_spaces = $10 ? $10 : '';
1030        my $locale_end_spaces = $13 ? $13 : '';
1031        my $c_default_block = $3 ? $3 : '';
1032        my $default_string = $6 ? $6 : '';
1033        my $short_string = $9 ? $9 : '';
1034        my $long_string = $12 ? $12 : '';
1035
1036        print OUTPUT "$locale_start_spaces$c_default_block";
1037
1038        $default_string =~ s/\s+/ /g;
1039        $default_string = entity_decode($default_string);
1040        $short_string =~ s/\s+/ /g;
1041        $short_string = entity_decode($short_string);
1042        $long_string =~ s/\s+/ /g;
1043        $long_string = entity_decode($long_string);
1044
1045        for my $lang (sort keys %po_files_by_lang)
1046        {
1047            my $default_translation = $translations{$lang, $default_string};
1048            my $short_translation = $translations{$lang, $short_string};
1049            my $long_translation  = $translations{$lang, $long_string};
1050
1051            next if (!$default_translation && !$short_translation &&
1052                     !$long_translation);
1053
1054            print OUTPUT "\n$locale_start_spaces<locale name=\"$lang\">";
1055
1056        print OUTPUT "$default_spaces";   
1057
1058        if ($default_translation)
1059        {
1060            $default_translation = entity_encode($default_translation);
1061            print OUTPUT "<default>$default_translation</default>";
1062        }
1063
1064            print OUTPUT "$short_spaces";
1065
1066            if ($short_translation)
1067            {
1068                        $short_translation = entity_encode($short_translation);
1069                        print OUTPUT "<short>$short_translation</short>";
1070            }
1071
1072            print OUTPUT "$long_spaces";
1073
1074            if ($long_translation)
1075            {
1076                        $long_translation = entity_encode($long_translation);
1077                        print OUTPUT "<long>$long_translation</long>";
1078            }       
1079
1080            print OUTPUT "$locale_end_spaces</locale>";
1081        }
1082    }
1083
1084    print OUTPUT $source;
1085
1086    close OUTPUT;
1087}
1088
1089sub rfc822deb_merge_translations
1090{
1091    my %encodings = ();
1092    for my $lang (keys %po_files_by_lang) {
1093        $encodings{$lang} = ($UTF8_ARG ? 'UTF-8' : get_po_encoding($po_files_by_lang{$lang}));
1094    }
1095
1096    my $source;
1097
1098    $Text::Wrap::huge = 'overflow';
1099    $Text::Wrap::break = qr/\n|\s(?=\S)/;
1100
1101    {
1102       local $/; # slurp mode
1103       open INPUT, "<$FILE" or die "can't open $FILE: $!";
1104       $source = <INPUT>;
1105       close INPUT;
1106    }
1107
1108    open OUTPUT, ">${OUTFILE}" or die;
1109
1110    while ($source =~ /(^|\n+)(_*)([^:\s]+)(:[ \t]*)(.*?)(?=\n[\S\n]|$)/sg)
1111    {
1112            my $sep = $1;
1113            my $non_translated_line = $3.$4;
1114            my $string = $5;
1115            my $underscore = length($2);
1116            next if $underscore eq 0 && $non_translated_line =~ /^#/;
1117            #  Remove [] dummy strings
1118            my $stripped = $string;
1119            $stripped =~ s/\[\s[^\[\]]*\],/,/g if $underscore eq 2;
1120            $stripped =~ s/\[\s[^\[\]]*\]$//;
1121            $non_translated_line .= $stripped;
1122
1123            print OUTPUT $sep.$non_translated_line;
1124   
1125            if ($underscore)
1126            {
1127                my @str_list = rfc822deb_split($underscore, $string);
1128
1129                for my $lang (sort keys %po_files_by_lang)
1130                {
1131                    my $is_translated = 1;
1132                    my $str_translated = '';
1133                    my $first = 1;
1134               
1135                    for my $str (@str_list)
1136                    {
1137                        my $translation = $translations{$lang, $str};
1138                   
1139                        if (!$translation)
1140                        {
1141                            $is_translated = 0;
1142                            last;
1143                        }
1144
1145                        #  $translation may also contain [] dummy
1146                        #  strings, mostly to indicate an empty string
1147                        $translation =~ s/\[\s[^\[\]]*\]$//;
1148                       
1149                        if ($first)
1150                        {
1151                            if ($underscore eq 2)
1152                            {
1153                                $str_translated .= $translation;
1154                            }
1155                            else
1156                            {
1157                                $str_translated .=
1158                                    Text::Tabs::expand($translation) .
1159                                    "\n";
1160                            }
1161                        }
1162                        else
1163                        {
1164                            if ($underscore eq 2)
1165                            {
1166                                $str_translated .= ', ' . $translation;
1167                            }
1168                            else
1169                            {
1170                                $str_translated .= Text::Tabs::expand(
1171                                    Text::Wrap::wrap(' ', ' ', $translation)) .
1172                                    "\n .\n";
1173                            }
1174                        }
1175                        $first = 0;
1176
1177                        #  To fix some problems with Text::Wrap::wrap
1178                        $str_translated =~ s/(\n )+\n/\n .\n/g;
1179                    }
1180                    next unless $is_translated;
1181
1182                    $str_translated =~ s/\n \.\n$//;
1183                    $str_translated =~ s/\s+$//;
1184
1185                    $_ = $non_translated_line;
1186                    s/^(\w+):\s*.*/$sep${1}-$lang.$encodings{$lang}: $str_translated/s;
1187                    print OUTPUT;
1188                }
1189            }
1190    }
1191    print OUTPUT "\n";
1192
1193    close OUTPUT;
1194    close INPUT;
1195}
1196
1197sub rfc822deb_split
1198{
1199    # Debian defines a special way to deal with rfc822-style files:
1200    # when a value contain newlines, it consists of
1201    #   1.  a short form (first line)
1202    #   2.  a long description, all lines begin with a space,
1203    #       and paragraphs are separated by a single dot on a line
1204    # This routine returns an array of all paragraphs, and reformat
1205    # them.
1206    # When first argument is 2, the string is a comma separated list of
1207    # values.
1208    my $type = shift;
1209    my $text = shift;
1210    $text =~ s/^[ \t]//mg;
1211    return (split(/, */, $text, 0)) if $type ne 1;
1212    return ($text) if $text !~ /\n/;
1213
1214    $text =~ s/([^\n]*)\n//;
1215    my @list = ($1);
1216    my $str = '';
1217
1218    for my $line (split (/\n/, $text))
1219    {
1220        chomp $line;
1221        if ($line =~ /^\.\s*$/)
1222        {
1223            #  New paragraph
1224            $str =~ s/\s*$//;
1225            push(@list, $str);
1226            $str = '';
1227        }
1228        elsif ($line =~ /^\s/)
1229        {
1230            #  Line which must not be reformatted
1231            $str .= "\n" if length ($str) && $str !~ /\n$/;
1232            $line =~ s/\s+$//;
1233            $str .= $line."\n";
1234        }
1235        else
1236        {
1237            #  Continuation line, remove newline
1238            $str .= " " if length ($str) && $str !~ /\n$/;
1239            $str .= $line;
1240        }
1241    }
1242
1243    $str =~ s/\s*$//;
1244    push(@list, $str) if length ($str);
1245
1246    return @list;
1247}
1248
Note: See TracBrowser for help on using the repository browser.