source: trunk/third/gnome-desktop/intltool-merge.in @ 18622

Revision 18622, 21.7 KB checked in by ghudson, 22 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r18621, which included commits to RCS files with non-trunk default branches.
Line 
1#!@INTLTOOL_PERL@ -w
2
3#
4#  The Intltool Message Merger
5#
6#  Copyright (C) 2000, 2003 Free Software Foundation.
7#  Copyright (C) 2000, 2001 Eazel, Inc
8#
9#  Intltool is free software; you can redistribute it and/or
10#  modify it under the terms of the GNU General Public License
11#  version 2 published by the Free Software Foundation.
12#
13#  Intltool is distributed in the hope that it will be useful,
14#  but WITHOUT ANY WARRANTY; without even the implied warranty of
15#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
16#  General Public License for more details.
17#
18#  You should have received a copy of the GNU General Public License
19#  along with this program; if not, write to the Free Software
20#  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
21#
22#  As a special exception to the GNU General Public License, if you
23#  distribute this file as part of a program that contains a
24#  configuration script generated by Autoconf, you may include it under
25#  the same distribution terms that you use for the rest of that program.
26#
27#  Authors:  Maciej Stachowiak <mjs@noisehavoc.org>
28#            Kenneth Christiansen <kenneth@gnu.org>
29#            Darin Adler <darin@bentspoon.com>
30#
31#  Proper XML UTF-8'ification written by Cyrille Chepelov <chepelov@calixo.net>
32#
33
34## Release information
35my $PROGRAM = "intltool-merge";
36my $PACKAGE = "intltool";
37my $VERSION = "0.25";
38
39## Loaded modules
40use strict;
41use Getopt::Long;
42use Text::Wrap;
43
44## Scalars used by the option stuff
45my $HELP_ARG = 0;
46my $VERSION_ARG = 0;
47my $BA_STYLE_ARG = 0;
48my $XML_STYLE_ARG = 0;
49my $KEYS_STYLE_ARG = 0;
50my $DESKTOP_STYLE_ARG = 0;
51my $SCHEMAS_STYLE_ARG = 0;
52my $RFC822DEB_STYLE_ARG = 0;
53my $QUIET_ARG = 0;
54my $PASS_THROUGH_ARG = 0;
55my $UTF8_ARG = 0;
56my $cache_file;
57
58## Handle options
59GetOptions
60(
61 "help" => \$HELP_ARG,
62 "version" => \$VERSION_ARG,
63 "quiet|q" => \$QUIET_ARG,
64 "oaf-style|o" => \$BA_STYLE_ARG, ## for compatibility
65 "ba-style|b" => \$BA_STYLE_ARG,
66 "xml-style|x" => \$XML_STYLE_ARG,
67 "keys-style|k" => \$KEYS_STYLE_ARG,
68 "desktop-style|d" => \$DESKTOP_STYLE_ARG,
69 "schemas-style|s" => \$SCHEMAS_STYLE_ARG,
70 "rfc822deb-style|r" => \$RFC822DEB_STYLE_ARG,
71 "pass-through|p" => \$PASS_THROUGH_ARG,
72 "utf8|u" => \$UTF8_ARG,
73 "cache|c=s" => \$cache_file
74 ) or &error;
75
76my $PO_DIR;
77my $FILE;
78my $OUTFILE;
79
80my %po_files_by_lang = ();
81my %translations = ();
82
83# Use this instead of \w for XML files to handle more possible characters.
84my $w = "[-A-Za-z0-9._:]";
85
86# XML quoted string contents
87my $q = "[^\\\"]*";
88
89## Check for options.
90
91if ($VERSION_ARG)
92{
93        &print_version;
94}
95elsif ($HELP_ARG)
96{
97        &print_help;
98}
99elsif ($BA_STYLE_ARG && @ARGV > 2)
100{
101        &preparation;
102        &print_message;
103        &ba_merge_translations;
104        &finalize;
105}
106elsif ($XML_STYLE_ARG && @ARGV > 2)
107{
108        &utf8_sanity_check;
109        &preparation;
110        &print_message;
111        &xml_merge_translations;
112        &finalize;
113}
114elsif ($KEYS_STYLE_ARG && @ARGV > 2)
115{
116        &utf8_sanity_check;
117        &preparation;
118        &print_message;
119        &keys_merge_translations;
120        &finalize;
121}
122elsif ($DESKTOP_STYLE_ARG && @ARGV > 2)
123{
124        &preparation;
125        &print_message;
126        &desktop_merge_translations;
127        &finalize;
128}
129elsif ($SCHEMAS_STYLE_ARG && @ARGV > 2)
130{
131        &preparation;
132        &print_message;
133        &schemas_merge_translations;
134        &finalize;
135}
136elsif ($RFC822DEB_STYLE_ARG && @ARGV > 2)
137{
138        &preparation;
139        &print_message;
140        &rfc822deb_merge_translations;
141        &finalize;
142}
143else
144{
145        &print_help;
146}
147
148exit;
149
150## Sub for printing release information
151sub print_version
152{
153    print "${PROGRAM} (${PACKAGE}) ${VERSION}\n";
154    print "Written by Maciej Stachowiak, Darin Adler and Kenneth Christiansen.\n\n";
155    print "Copyright (C) 2000-2002 Free Software Foundation, Inc.\n";
156    print "Copyright (C) 2000-2001 Eazel, Inc.\n";
157    print "This is free software; see the source for copying conditions.  There is NO\n";
158    print "warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n";
159    exit;
160}
161
162## Sub for printing usage information
163sub print_help
164{
165    print "Usage: ${PROGRAM} [OPTIONS] PO_DIRECTORY FILENAME OUTPUT_FILE\n";
166    print "Generates an output file that includes translated versions of some attributes,\n";
167    print "from an untranslated source and a po directory that includes translations.\n\n";
168    print "  -b, --ba-style         includes translations in the bonobo-activation style\n";
169    print "  -d, --desktop-style    includes translations in the desktop style\n";
170    print "  -k, --keys-style       includes translations in the keys style\n";
171    print "  -s, --schemas-style    includes translations in the schemas style\n";
172    print "  -r, --rfc822deb-style  includes translations in the RFC822 style\n";
173    print "  -x, --xml-style        includes translations in the standard xml style\n";
174    print "  -u, --utf8             convert all strings to UTF-8 before merging\n";
175    print "  -p, --pass-through     use strings as found in .po files, without\n";
176    print "                         conversion (STRONGLY unrecommended with -x)\n";
177    print "  -q, --quiet            suppress most messages\n";
178    print "      --help             display this help and exit\n";
179    print "      --version          output version information and exit\n";
180    print "\nReport bugs to bugzilla.gnome.org, module intltool, or contact us through \n";
181    print "<xml-i18n-tools-list\@gnome.org>.\n";
182    exit;
183}
184
185
186## Sub for printing error messages
187sub print_error
188{
189    print "Try `${PROGRAM} --help' for more information.\n";
190    exit;
191}
192
193
194sub print_message
195{
196    print "Merging translations into $OUTFILE.\n" unless $QUIET_ARG;
197}
198
199
200sub preparation
201{
202    $PO_DIR = $ARGV[0];
203    $FILE = $ARGV[1];
204    $OUTFILE = $ARGV[2];
205
206    &gather_po_files;
207    &get_translation_database;
208}
209
210# General-purpose code for looking up translations in .po files
211
212sub po_file2lang
213{
214    my ($tmp) = @_;
215    $tmp =~ s/^.*\/(.*)\.po$/$1/;
216    return $tmp;
217}
218
219sub gather_po_files
220{
221    for my $po_file (glob "$PO_DIR/*.po") {
222        $po_files_by_lang{po_file2lang($po_file)} = $po_file;
223    }
224}
225
226sub get_local_charset
227{
228    my ($encoding) = @_;
229    my $alias_file = $ENV{"G_CHARSET_ALIAS"} || "/gnome/head/INSTALL/lib/charset.alias";
230
231    # seek character encoding aliases in charset.alias (glib)
232
233    if (open CHARSET_ALIAS, $alias_file)
234    {
235        while (<CHARSET_ALIAS>)
236        {
237            next if /^\#/;
238            return $1 if (/^\s*([-._a-zA-Z0-9]+)\s+$encoding\b/i)
239        }
240
241        close CHARSET_ALIAS;
242    }
243
244    # if not found, return input string
245
246    return $encoding;
247}
248
249sub get_po_encoding
250{
251    my ($in_po_file) = @_;
252    my $encoding = "";
253
254    open IN_PO_FILE, $in_po_file or die;
255    while (<IN_PO_FILE>)
256    {
257        ## example: "Content-Type: text/plain; charset=ISO-8859-1\n"
258        if (/Content-Type\:.*charset=([-a-zA-Z0-9]+)\\n/)
259        {
260            $encoding = $1;
261            last;
262        }
263    }
264    close IN_PO_FILE;
265
266    if (!$encoding)
267    {
268        print "Warning: no encoding found in $in_po_file. Assuming ISO-8859-1\n";
269        $encoding = "ISO-8859-1";
270    }
271
272    $encoding = get_local_charset($encoding);
273
274    return $encoding
275}
276
277sub utf8_sanity_check
278{
279    if (!$UTF8_ARG)
280    {
281        if (!$PASS_THROUGH_ARG)
282        {
283            $PASS_THROUGH_ARG="1";
284        }
285    }
286}
287
288sub get_translation_database
289{
290    if ($cache_file) {
291        &get_cached_translation_database;
292    } else {
293        &create_translation_database;
294    }
295}
296
297sub get_newest_po_age
298{
299    my $newest_age;
300
301    foreach my $file (values %po_files_by_lang)
302    {
303        my $file_age = -M $file;
304        $newest_age = $file_age if !$newest_age || $file_age < $newest_age;
305    }
306
307    return $newest_age;
308}
309
310sub create_cache
311{
312    print "Generating and caching the translation database\n" unless $QUIET_ARG;
313
314    &create_translation_database;
315
316    open CACHE, ">$cache_file" || die;
317    print CACHE join "\x01", %translations;
318    close CACHE;
319}
320
321sub load_cache
322{
323    print "Found cached translation database\n" unless $QUIET_ARG;
324
325    my $contents;
326    open CACHE, "<$cache_file" || die;
327    {
328        local $/;
329        $contents = <CACHE>;
330    }
331    close CACHE;
332    %translations = split "\x01", $contents;
333}
334
335sub get_cached_translation_database
336{
337    my $cache_file_age = -M $cache_file;
338    if (defined $cache_file_age)
339    {
340        if ($cache_file_age <= &get_newest_po_age)
341        {
342            &load_cache;
343            return;
344        }
345        print "Found too-old cached translation database\n" unless $QUIET_ARG;
346    }
347
348    &create_cache;
349}
350
351sub create_translation_database
352{
353    for my $lang (keys %po_files_by_lang)
354    {
355        my $po_file = $po_files_by_lang{$lang};
356
357        if ($UTF8_ARG)
358        {
359            my $encoding = get_po_encoding ($po_file);
360
361            if (lc $encoding eq "utf-8")
362            {
363                open PO_FILE, "<$po_file";     
364            }
365            else
366            {
367                print "WARNING: $po_file is not in UTF-8 but $encoding, converting...\n";
368
369                my $iconv = $ENV{"INTLTOOL_ICONV"} || "iconv";
370                open PO_FILE, "$iconv -f $encoding -t UTF-8 $po_file|";
371            }
372        }
373        else
374        {
375            open PO_FILE, "<$po_file"; 
376        }
377
378        my $nextfuzzy = 0;
379        my $inmsgid = 0;
380        my $inmsgstr = 0;
381        my $msgid = "";
382        my $msgstr = "";
383
384        while (<PO_FILE>)
385        {
386            $nextfuzzy = 1 if /^#, fuzzy/;
387       
388            if (/^msgid "((\\.|[^\\])*)"/ )
389            {
390                $translations{$lang, $msgid} = $msgstr if $inmsgstr && $msgid && $msgstr;
391                $msgid = "";
392                $msgstr = "";
393
394                if ($nextfuzzy) {
395                    $inmsgid = 0;
396                } else {
397                    $msgid = unescape_po_string($1);
398                    $inmsgid = 1;
399                }
400                $inmsgstr = 0;
401                $nextfuzzy = 0;
402            }
403
404            if (/^msgstr "((\\.|[^\\])*)"/)
405            {
406                $msgstr = unescape_po_string($1);
407                $inmsgstr = 1;
408                $inmsgid = 0;
409            }
410
411            if (/^"((\\.|[^\\])*)"/)
412            {
413                $msgid .= unescape_po_string($1) if $inmsgid;
414                $msgstr .= unescape_po_string($1) if $inmsgstr;
415            }
416        }
417        $translations{$lang, $msgid} = $msgstr if $inmsgstr && $msgid && $msgstr;
418    }
419}
420
421sub finalize
422{
423}
424
425sub unescape_one_sequence
426{
427    my ($sequence) = @_;
428
429    return "\\" if $sequence eq "\\\\";
430    return "\"" if $sequence eq "\\\"";
431    return "\n" if $sequence eq "\\n";
432
433    # gettext also handles \n, \t, \b, \r, \f, \v, \a, \xxx (octal),
434    # \xXX (hex) and has a comment saying they want to handle \u and \U.
435
436    return $sequence;
437}
438
439sub unescape_po_string
440{
441    my ($string) = @_;
442
443    $string =~ s/(\\.)/unescape_one_sequence($1)/eg;
444
445    return $string;
446}
447
448## NOTE: deal with < - &lt; but not > - &gt;  because it seems its ok to have
449## > in the entity. For further info please look at #84738.
450sub entity_decode
451{
452    local ($_) = @_;
453
454    s/&apos;/'/g; # '
455    s/&quot;/"/g; # "
456    s/&amp;/&/g;
457    s/&lt;/</g;
458
459    return $_;
460}
461 
462# entity_encode: (string)
463#
464# Encode the given string to XML format (encode '<' etc). It also
465# encodes high bit if not in UTF-8 mode.
466
467sub entity_encode
468{
469    my ($pre_encoded) = @_;
470
471    my @list_of_chars = unpack ('C*', $pre_encoded);
472
473    if ($PASS_THROUGH_ARG)
474    {
475        return join ('', map (&entity_encode_int_even_high_bit, @list_of_chars));
476    }
477    else
478    {
479        # with UTF-8 we only encode minimalistic
480        return join ('', map (&entity_encode_int_minimalist, @list_of_chars));
481    }
482}
483
484sub entity_encode_int_minimalist
485{
486    return "&quot;" if $_ == 34;
487    return "&amp;" if $_ == 38;
488    return "&apos;" if $_ == 39;
489    return "&lt;" if $_ == 60;
490    return chr $_;
491}
492
493sub entity_encode_int_even_high_bit
494{
495    if ($_ > 127 || $_ == 34 || $_ == 38 || $_ == 39 || $_ == 60)
496    {
497        # the ($_ > 127) should probably be removed
498        return "&#" . $_ . ";";
499    }
500    else
501    {
502        return chr $_;
503    }
504}
505
506sub entity_encoded_translation
507{
508    my ($lang, $string) = @_;
509
510    my $translation = $translations{$lang, $string};
511    return $string if !$translation;
512    return entity_encode ($translation);
513}
514
515## XML (bonobo-activation specific) merge code
516
517sub ba_merge_translations
518{
519    my $source;
520
521    {
522       local $/; # slurp mode
523       open INPUT, "<$FILE" or die "can't open $FILE: $!";
524       $source = <INPUT>;
525       close INPUT;
526    }
527
528    open OUTPUT, ">$OUTFILE" or die "can't open $OUTFILE: $!";
529
530    while ($source =~ s|^(.*?)([ \t]*<\s*$w+\s+($w+\s*=\s*"$q"\s*)+/?>)([ \t]*\n)?||s)
531    {
532        print OUTPUT $1;
533
534        my $node = $2 . "\n";
535
536        my @strings = ();
537        $_ = $node;
538        while (s/(\s)_($w+\s*=\s*"($q)")/$1$2/s) {
539             push @strings, entity_decode($3);
540        }
541        print OUTPUT;
542
543        my %langs;
544        for my $string (@strings)
545        {
546            for my $lang (keys %po_files_by_lang)
547            {
548                $langs{$lang} = 1 if $translations{$lang, $string};
549            }
550        }
551       
552        for my $lang (sort keys %langs)
553        {
554            $_ = $node;
555            s/(\sname\s*=\s*)"($q)"/$1"$2-$lang"/s;
556            s/(\s)_($w+\s*=\s*")($q)"/$1 . $2 . entity_encoded_translation($lang, $3) . '"'/seg;
557            print OUTPUT;
558        }
559    }
560
561    print OUTPUT $source;
562
563    close OUTPUT;
564}
565
566
567## XML (non-bonobo-activation) merge code
568
569sub xml_merge_translations
570{
571    my $source;
572
573    {
574       local $/; # slurp mode
575       open INPUT, "<$FILE" or die "can't open $FILE: $!";
576       $source = <INPUT>;
577       close INPUT;
578    }
579
580    open OUTPUT, ">$OUTFILE" or die;
581
582    # FIXME: support attribute translations
583
584    # Empty nodes never need translation, so unmark all of them.
585    # For example, <_foo/> is just replaced by <foo/>.
586    $source =~ s|<\s*_($w+)\s*/>|<$1/>|g;
587
588    # Support for <_foo>blah</_foo> style translations.
589    while ($source =~ s|^(.*?)([ \t]*)<\s*_($w+)\s*>(.*?)<\s*/_\3\s*>([ \t]*\n)?||s)
590    {
591        print OUTPUT $1;
592
593        my $spaces = $2;
594        my $tag = $3;
595        my $string = $4;
596
597        print OUTPUT "$spaces<$tag>$string</$tag>\n";
598
599        $string =~ s/\s+/ /g;
600        $string =~ s/^ //;
601        $string =~ s/ $//;
602        $string = entity_decode($string);
603
604        for my $lang (sort keys %po_files_by_lang)
605        {
606            my $translation = $translations{$lang, $string};
607            next if !$translation;
608            $translation = entity_encode($translation);
609            print OUTPUT "$spaces<$tag xml:lang=\"$lang\">$translation</$tag>\n";
610        }
611    }
612
613    print OUTPUT $source;
614
615    close OUTPUT;
616}
617
618sub keys_merge_translations
619{
620    open INPUT, "<${FILE}" or die;
621    open OUTPUT, ">${OUTFILE}" or die;
622
623    while (<INPUT>)
624    {
625        if (s/^(\s*)_(\w+=(.*))/$1$2/) 
626        {
627            my $string = $3;
628
629            print OUTPUT;
630
631            my $non_translated_line = $_;
632
633            for my $lang (sort keys %po_files_by_lang)
634            {
635                my $translation = $translations{$lang, $string};
636                next if !$translation;
637
638                $_ = $non_translated_line;
639                s/(\w+)=.*/[$lang]$1=$translation/;
640                print OUTPUT;
641            }
642        }
643        else
644        {
645            print OUTPUT;
646        }
647    }
648
649    close OUTPUT;
650    close INPUT;
651}
652
653sub desktop_merge_translations
654{
655    open INPUT, "<${FILE}" or die;
656    open OUTPUT, ">${OUTFILE}" or die;
657
658    while (<INPUT>)
659    {
660        if (s/^(\s*)_(\w+=(.*))/$1$2/) 
661        {
662            my $string = $3;
663
664            print OUTPUT;
665
666            my $non_translated_line = $_;
667
668            for my $lang (sort keys %po_files_by_lang)
669            {
670                my $translation = $translations{$lang, $string};
671                next if !$translation;
672
673                $_ = $non_translated_line;
674                s/(\w+)=.*/${1}[$lang]=$translation/;
675                print OUTPUT;
676            }
677        }
678        else
679        {
680            print OUTPUT;
681        }
682    }
683
684    close OUTPUT;
685    close INPUT;
686}
687
688sub schemas_merge_translations
689{
690    my $source;
691
692    {
693       local $/; # slurp mode
694       open INPUT, "<$FILE" or die "can't open $FILE: $!";
695       $source = <INPUT>;
696       close INPUT;
697    }
698
699    open OUTPUT, ">$OUTFILE" or die;
700
701    # FIXME: support attribute translations
702
703    # Empty nodes never need translation, so unmark all of them.
704    # For example, <_foo/> is just replaced by <foo/>.
705    $source =~ s|<\s*_($w+)\s*/>|<$1/>|g;
706
707    while ($source =~ s/
708                        (.*?)
709                        (\s+)(<locale\ name="C">(\s*)
710                            (<default>\s*(.*?)\s*<\/default>)?(\s*)
711                            (<short>\s*(.*?)\s*<\/short>)?(\s*)
712                            (<long>\s*(.*?)\s*<\/long>)?(\s*)
713                        <\/locale>)
714                       //sx)
715    {
716        print OUTPUT $1;
717
718        my $locale_start_spaces = $2 ? $2 : '';
719        my $default_spaces = $4 ? $4 : '';
720        my $short_spaces = $7 ? $7 : '';
721        my $long_spaces = $10 ? $10 : '';
722        my $locale_end_spaces = $13 ? $13 : '';
723        my $c_default_block = $3 ? $3 : '';
724        my $default_string = $6 ? $6 : '';
725        my $short_string = $9 ? $9 : '';
726        my $long_string = $12 ? $12 : '';
727
728        $c_default_block =~ s/default>\[.*?\]/default>/s;
729       
730        print OUTPUT "$locale_start_spaces$c_default_block";
731
732        $default_string =~ s/\s+/ /g;
733        $default_string = entity_decode($default_string);
734        $short_string =~ s/\s+/ /g;
735        $short_string = entity_decode($short_string);
736        $long_string =~ s/\s+/ /g;
737        $long_string = entity_decode($long_string);
738
739        for my $lang (sort keys %po_files_by_lang)
740        {
741            my $default_translation = $translations{$lang, $default_string};
742            my $short_translation = $translations{$lang, $short_string};
743            my $long_translation  = $translations{$lang, $long_string};
744
745            next if (!$default_translation && !$short_translation &&
746                     !$long_translation);
747
748            print OUTPUT "\n$locale_start_spaces<locale name=\"$lang\">";
749
750        print OUTPUT "$default_spaces";   
751
752        if ($default_translation)
753        {
754            $default_translation = entity_encode($default_translation);
755            print OUTPUT "<default>$default_translation</default>";
756        }
757
758            print OUTPUT "$short_spaces";
759
760            if ($short_translation)
761            {
762                        $short_translation = entity_encode($short_translation);
763                        print OUTPUT "<short>$short_translation</short>";
764            }
765
766            print OUTPUT "$long_spaces";
767
768            if ($long_translation)
769            {
770                        $long_translation = entity_encode($long_translation);
771                        print OUTPUT "<long>$long_translation</long>";
772            }       
773
774            print OUTPUT "$locale_end_spaces</locale>";
775        }
776    }
777
778    print OUTPUT $source;
779
780    close OUTPUT;
781}
782
783sub rfc822deb_merge_translations
784{
785    my $source;
786
787    $Text::Wrap::huge = 'overflow';
788
789    {
790       local $/; # slurp mode
791       open INPUT, "<$FILE" or die "can't open $FILE: $!";
792       $source = <INPUT>;
793       close INPUT;
794    }
795
796    open OUTPUT, ">${OUTFILE}" or die;
797
798    while ($source =~ /(^|\n+)(_)?([^:_\n]+)(:\s*)(.*?)(?=\n[\S\n]|$)/sg)
799    {
800            my $sep = $1;
801            my $non_translated_line = $3.$4;
802            my $string = $5;
803            my $is_translatable = defined($2);
804            #  Remove [] dummy strings
805            $string =~ s/\[\s[^\[\]]*\]$//;
806            $non_translated_line .= $string;
807
808            print OUTPUT $sep.$non_translated_line;
809   
810            if ($is_translatable)
811            {
812                my @str_list = rfc822deb_split($string);
813           
814                for my $lang (sort keys %po_files_by_lang)
815                {
816                    my $is_translated = 1;
817                    my $str_translated = '';
818                    my $first = 1;
819               
820                    for my $str (@str_list)
821                    {
822                        my $translation = $translations{$lang, $str};
823                   
824                        if (!$translation)
825                        {
826                            $is_translated = 0;
827                            last;
828                        }
829
830                        #  $translation may also contain [] dummy
831                        #  strings, mostly to indicate an empty string
832                        $translation =~ s/\[\s[^\[\]]*\]$//;
833                       
834                        if ($first)
835                        {
836                            $str_translated .=
837                                Text::Tabs::expand($translation) .
838                                "\n";
839                        }
840                        else
841                        {
842                            $str_translated .= Text::Tabs::expand(
843                                Text::Wrap::wrap(' ', ' ', $translation)) .
844                                "\n .\n";
845                        }
846                        $first = 0;
847
848                        #  To fix some problems with Text::Wrap::wrap
849                        $str_translated =~ s/(\n )+\n/\n .\n/g;
850                    }
851                    next unless $is_translated;
852
853                    $str_translated =~ s/\n \.\n$//;
854                    $str_translated =~ s/\s+$//;
855
856                    $_ = $non_translated_line;
857                    s/^(\w+):\s*.*/$sep${1}-$lang: $str_translated/s;
858                    print OUTPUT;
859                }
860            }
861    }
862    print OUTPUT "\n";
863
864    close OUTPUT;
865    close INPUT;
866}
867
868sub rfc822deb_split
869{
870    # Debian defines a special way to deal with rfc822-style files:
871    # when a value contain newlines, it consists of
872    #   1.  a short form (first line)
873    #   2.  a long description, all lines begin with a space,
874    #       and paragraphs are separated by a single dot on a line
875    # This routine returns an array of all paragraphs, and reformat
876    # them.
877    my $text = shift;
878    $text =~ s/^ //mg;
879    return ($text) if $text !~ /\n/;
880
881    $text =~ s/([^\n]*)\n//;
882    my @list = ($1);
883    my $str = '';
884
885    for my $line (split (/\n/, $text))
886    {
887        chomp $line;
888        $line =~ /\s+$/;
889   
890        if ($line =~ /^\.$/)
891        {
892            #  New paragraph
893            $str =~ s/\s*$//;
894            push(@list, $str);
895            $str = '';
896        }
897        elsif ($line =~ /^\s/)
898        {
899            #  Line which must not be reformatted
900            $str .= "\n" if length ($str) && $str !~ /\n$/;
901            $str .= $line."\n";
902        }
903        else
904        {
905            #  Continuation line, remove newline
906            $str .= " " if length ($str) && $str !~ /[\n ]$/;
907            $str .= $line;
908        }
909    }
910
911    $str =~ s/\s*$//;
912    push(@list, $str) if length ($str);
913
914    return @list;
915}
916
Note: See TracBrowser for help on using the repository browser.