source: trunk/third/gnome-applets/intltool-merge.in @ 18647

Revision 18647, 21.5 KB checked in by ghudson, 21 years ago (diff)
This commit was generated by cvs2svn to compensate for changes in r18646, 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, 2002 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.23";
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"} || "/usr/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                my $iconv = $ENV{"INTLTOOL_ICONV"} || "iconv";
368                open PO_FILE, "$iconv -f $encoding -t UTF-8 $po_file|";
369            }
370        }
371        else
372        {
373            open PO_FILE, "<$po_file"; 
374        }
375
376        my $nextfuzzy = 0;
377        my $inmsgid = 0;
378        my $inmsgstr = 0;
379        my $msgid = "";
380        my $msgstr = "";
381
382        while (<PO_FILE>)
383        {
384            $nextfuzzy = 1 if /^#, fuzzy/;
385       
386            if (/^msgid "((\\.|[^\\])*)"/ )
387            {
388                $translations{$lang, $msgid} = $msgstr if $inmsgstr && $msgid && $msgstr;
389                $msgid = "";
390                $msgstr = "";
391
392                if ($nextfuzzy) {
393                    $inmsgid = 0;
394                } else {
395                    $msgid = unescape_po_string($1);
396                    $inmsgid = 1;
397                }
398                $inmsgstr = 0;
399                $nextfuzzy = 0;
400            }
401
402            if (/^msgstr "((\\.|[^\\])*)"/)
403            {
404                $msgstr = unescape_po_string($1);
405                $inmsgstr = 1;
406                $inmsgid = 0;
407            }
408
409            if (/^"((\\.|[^\\])*)"/)
410            {
411                $msgid .= unescape_po_string($1) if $inmsgid;
412                $msgstr .= unescape_po_string($1) if $inmsgstr;
413            }
414        }
415        $translations{$lang, $msgid} = $msgstr if $inmsgstr && $msgid && $msgstr;
416    }
417}
418
419sub finalize
420{
421}
422
423sub unescape_one_sequence
424{
425    my ($sequence) = @_;
426
427    return "\\" if $sequence eq "\\\\";
428    return "\"" if $sequence eq "\\\"";
429    return "\n" if $sequence eq "\\n";
430
431    # gettext also handles \n, \t, \b, \r, \f, \v, \a, \xxx (octal),
432    # \xXX (hex) and has a comment saying they want to handle \u and \U.
433
434    return $sequence;
435}
436
437sub unescape_po_string
438{
439    my ($string) = @_;
440
441    $string =~ s/(\\.)/unescape_one_sequence($1)/eg;
442
443    return $string;
444}
445
446## NOTE: deal with < - &lt; but not > - &gt;  because it seems its ok to have
447## > in the entity. For further info please look at #84738.
448sub entity_decode
449{
450    local ($_) = @_;
451
452    s/&apos;/'/g; # '
453    s/&quot;/"/g; # "
454    s/&amp;/&/g;
455    s/&lt;/</g;
456
457    return $_;
458}
459
460sub entity_encode
461{
462    my ($pre_encoded) = @_;
463
464    my @list_of_chars = unpack ('C*', $pre_encoded);
465
466    if ($PASS_THROUGH_ARG)
467    {
468        return join ('', map (&entity_encode_int_even_high_bit, @list_of_chars));
469    }
470    else
471    {
472        return join ('', map (&entity_encode_int_minimalist, @list_of_chars));
473    }
474}
475
476sub entity_encode_int_minimalist
477{
478    return "&quot;" if $_ == 34;
479    return "&amp;" if $_ == 38;
480    return "&apos;" if $_ == 39;
481    return "&lt;" if $_ == 60;
482    return chr $_;
483}
484
485sub entity_encode_int_even_high_bit
486{
487    if ($_ > 127 || $_ == 34 || $_ == 38 || $_ == 39 || $_ == 60)
488    {
489        # the ($_ > 127) should probably be removed
490        return "&#" . $_ . ";";
491    }
492    else
493    {
494        return chr $_;
495    }
496}
497
498sub entity_encoded_translation
499{
500    my ($lang, $string) = @_;
501
502    my $translation = $translations{$lang, $string};
503    return $string if !$translation;
504    return entity_encode ($translation);
505}
506
507## XML (bonobo-activation specific) merge code
508
509sub ba_merge_translations
510{
511    my $source;
512
513    {
514       local $/; # slurp mode
515       open INPUT, "<$FILE" or die "can't open $FILE: $!";
516       $source = <INPUT>;
517       close INPUT;
518    }
519
520    open OUTPUT, ">$OUTFILE" or die "can't open $OUTFILE: $!";
521
522    while ($source =~ s|^(.*?)([ \t]*<\s*$w+\s+($w+\s*=\s*"$q"\s*)+/?>)([ \t]*\n)?||s)
523    {
524        print OUTPUT $1;
525
526        my $node = $2 . "\n";
527
528        my @strings = ();
529        $_ = $node;
530        while (s/(\s)_($w+\s*=\s*"($q)")/$1$2/s) {
531             push @strings, entity_decode($3);
532        }
533        print OUTPUT;
534
535        my %langs;
536        for my $string (@strings)
537        {
538            for my $lang (keys %po_files_by_lang)
539            {
540                $langs{$lang} = 1 if $translations{$lang, $string};
541            }
542        }
543       
544        for my $lang (sort keys %langs)
545        {
546            $_ = $node;
547            s/(\sname\s*=\s*)"($q)"/$1"$2-$lang"/s;
548            s/(\s)_($w+\s*=\s*")($q)"/$1 . $2 . entity_encoded_translation($lang, $3) . '"'/seg;
549            print OUTPUT;
550        }
551    }
552
553    print OUTPUT $source;
554
555    close OUTPUT;
556}
557
558
559## XML (non-bonobo-activation) merge code
560
561sub xml_merge_translations
562{
563    my $source;
564
565    {
566       local $/; # slurp mode
567       open INPUT, "<$FILE" or die "can't open $FILE: $!";
568       $source = <INPUT>;
569       close INPUT;
570    }
571
572    open OUTPUT, ">$OUTFILE" or die;
573
574    # FIXME: support attribute translations
575
576    # Empty nodes never need translation, so unmark all of them.
577    # For example, <_foo/> is just replaced by <foo/>.
578    $source =~ s|<\s*_($w+)\s*/>|<$1/>|g;
579
580    # Support for <_foo>blah</_foo> style translations.
581    while ($source =~ s|^(.*?)([ \t]*)<\s*_($w+)\s*>(.*?)<\s*/_\3\s*>([ \t]*\n)?||s)
582    {
583        print OUTPUT $1;
584
585        my $spaces = $2;
586        my $tag = $3;
587        my $string = $4;
588
589        print OUTPUT "$spaces<$tag>$string</$tag>\n";
590
591        $string =~ s/\s+/ /g;
592        $string =~ s/^ //;
593        $string =~ s/ $//;
594        $string = entity_decode($string);
595
596        for my $lang (sort keys %po_files_by_lang)
597        {
598            my $translation = $translations{$lang, $string};
599            next if !$translation;
600            $translation = entity_encode($translation);
601            print OUTPUT "$spaces<$tag xml:lang=\"$lang\">$translation</$tag>\n";
602        }
603    }
604
605    print OUTPUT $source;
606
607    close OUTPUT;
608}
609
610sub keys_merge_translations
611{
612    open INPUT, "<${FILE}" or die;
613    open OUTPUT, ">${OUTFILE}" or die;
614
615    while (<INPUT>)
616    {
617        if (s/^(\s*)_(\w+=(.*))/$1$2/) 
618        {
619            my $string = $3;
620
621            print OUTPUT;
622
623            my $non_translated_line = $_;
624
625            for my $lang (sort keys %po_files_by_lang)
626            {
627                my $translation = $translations{$lang, $string};
628                next if !$translation;
629
630                $_ = $non_translated_line;
631                s/(\w+)=.*/[$lang]$1=$translation/;
632                print OUTPUT;
633            }
634        }
635        else
636        {
637            print OUTPUT;
638        }
639    }
640
641    close OUTPUT;
642    close INPUT;
643}
644
645sub desktop_merge_translations
646{
647    open INPUT, "<${FILE}" or die;
648    open OUTPUT, ">${OUTFILE}" or die;
649
650    while (<INPUT>)
651    {
652        if (s/^(\s*)_(\w+=(.*))/$1$2/) 
653        {
654            my $string = $3;
655
656            print OUTPUT;
657
658            my $non_translated_line = $_;
659
660            for my $lang (sort keys %po_files_by_lang)
661            {
662                my $translation = $translations{$lang, $string};
663                next if !$translation;
664
665                $_ = $non_translated_line;
666                s/(\w+)=.*/${1}[$lang]=$translation/;
667                print OUTPUT;
668            }
669        }
670        else
671        {
672            print OUTPUT;
673        }
674    }
675
676    close OUTPUT;
677    close INPUT;
678}
679
680sub schemas_merge_translations
681{
682    my $source;
683
684    {
685       local $/; # slurp mode
686       open INPUT, "<$FILE" or die "can't open $FILE: $!";
687       $source = <INPUT>;
688       close INPUT;
689    }
690
691    open OUTPUT, ">$OUTFILE" or die;
692
693    # FIXME: support attribute translations
694
695    # Empty nodes never need translation, so unmark all of them.
696    # For example, <_foo/> is just replaced by <foo/>.
697    $source =~ s|<\s*_($w+)\s*/>|<$1/>|g;
698
699    while ($source =~ s/
700                        (.*?)
701                        (\s+)(<locale\ name="C">(\s*)
702                            (<default>\s*(.*?)\s*<\/default>)?(\s*)
703                            (<short>\s*(.*?)\s*<\/short>)?(\s*)
704                            (<long>\s*(.*?)\s*<\/long>)?(\s*)
705                        <\/locale>)
706                       //sx)
707    {
708        print OUTPUT $1;
709
710        my $locale_start_spaces = $2 ? $2 : '';
711        my $default_spaces = $4 ? $4 : '';
712        my $short_spaces = $7 ? $7 : '';
713        my $long_spaces = $10 ? $10 : '';
714        my $locale_end_spaces = $13 ? $13 : '';
715        my $c_default_block = $3 ? $3 : '';
716        my $default_string = $6 ? $6 : '';
717        my $short_string = $9 ? $9 : '';
718        my $long_string = $12 ? $12 : '';
719
720        $c_default_block =~ s/default>\[.*?\]/default>/s;
721       
722        print OUTPUT "$locale_start_spaces$c_default_block";
723
724        $default_string =~ s/\s+/ /g;
725        $default_string = entity_decode($default_string);
726        $short_string =~ s/\s+/ /g;
727        $short_string = entity_decode($short_string);
728        $long_string =~ s/\s+/ /g;
729        $long_string = entity_decode($long_string);
730
731        for my $lang (sort keys %po_files_by_lang)
732        {
733            my $default_translation = $translations{$lang, $default_string};
734            my $short_translation = $translations{$lang, $short_string};
735            my $long_translation  = $translations{$lang, $long_string};
736
737            next if (!$default_translation && !$short_translation &&
738                     !$long_translation);
739
740            print OUTPUT "\n$locale_start_spaces<locale name=\"$lang\">";
741
742        print OUTPUT "$default_spaces";   
743
744        if ($default_translation)
745        {
746            $default_translation = entity_encode($default_translation);
747            print OUTPUT "<default>$default_translation</default>";
748        }
749
750            print OUTPUT "$short_spaces";
751
752            if ($short_translation)
753            {
754                        $short_translation = entity_encode($short_translation);
755                        print OUTPUT "<short>$short_translation</short>";
756            }
757
758            print OUTPUT "$long_spaces";
759
760            if ($long_translation)
761            {
762                        $long_translation = entity_encode($long_translation);
763                        print OUTPUT "<long>$long_translation</long>";
764            }       
765
766            print OUTPUT "$locale_end_spaces</locale>";
767        }
768    }
769
770    print OUTPUT $source;
771
772    close OUTPUT;
773}
774
775sub rfc822deb_merge_translations
776{
777    my $source;
778
779    $Text::Wrap::huge = 'overflow';
780
781    {
782       local $/; # slurp mode
783       open INPUT, "<$FILE" or die "can't open $FILE: $!";
784       $source = <INPUT>;
785       close INPUT;
786    }
787
788    open OUTPUT, ">${OUTFILE}" or die;
789
790    while ($source =~ /(^|\n+)(_)?([^:_\n]+)(:\s*)(.*?)(?=\n[\S\n]|$)/sg)
791    {
792            my $sep = $1;
793            my $non_translated_line = $3.$4;
794            my $string = $5;
795            my $is_translatable = defined($2);
796            #  Remove [] dummy strings
797            $string =~ s/\[\s[^\[\]]*\]$//;
798            $non_translated_line .= $string;
799
800            print OUTPUT $sep.$non_translated_line;
801   
802            if ($is_translatable)
803            {
804                my @str_list = rfc822deb_split($string);
805           
806                for my $lang (sort keys %po_files_by_lang)
807                {
808                    my $is_translated = 1;
809                    my $str_translated = '';
810                    my $first = 1;
811               
812                    for my $str (@str_list)
813                    {
814                        my $translation = $translations{$lang, $str};
815                   
816                        if (!$translation)
817                        {
818                            $is_translated = 0;
819                            last;
820                        }
821
822                        #  $translation may also contain [] dummy
823                        #  strings, mostly to indicate an empty string
824                        $translation =~ s/\[\s[^\[\]]*\]$//;
825                       
826                        if ($first)
827                        {
828                            $str_translated .=
829                                Text::Tabs::expand($translation) .
830                                "\n";
831                        }
832                        else
833                        {
834                            $str_translated .= Text::Tabs::expand(
835                                Text::Wrap::wrap(' ', ' ', $translation)) .
836                                "\n .\n";
837                        }
838                        $first = 0;
839
840                        #  To fix some problems with Text::Wrap::wrap
841                        $str_translated =~ s/(\n )+\n/\n .\n/g;
842                    }
843                    next unless $is_translated;
844
845                    $str_translated =~ s/\n \.\n$//;
846                    $str_translated =~ s/\s+$//;
847
848                    $_ = $non_translated_line;
849                    s/^(\w+):\s*.*/$sep${1}-$lang: $str_translated/s;
850                    print OUTPUT;
851                }
852            }
853    }
854    print OUTPUT "\n";
855
856    close OUTPUT;
857    close INPUT;
858}
859
860sub rfc822deb_split
861{
862    # Debian defines a special way to deal with rfc822-style files:
863    # when a value contain newlines, it consists of
864    #   1.  a short form (first line)
865    #   2.  a long description, all lines begin with a space,
866    #       and paragraphs are separated by a single dot on a line
867    # This routine returns an array of all paragraphs, and reformat
868    # them.
869    my $text = shift;
870    $text =~ s/^ //mg;
871    return ($text) if $text !~ /\n/;
872
873    $text =~ s/([^\n]*)\n//;
874    my @list = ($1);
875    my $str = '';
876
877    for my $line (split (/\n/, $text))
878    {
879        chomp $line;
880        $line =~ /\s+$/;
881   
882        if ($line =~ /^\.$/)
883        {
884            #  New paragraph
885            $str =~ s/\s*$//;
886            push(@list, $str);
887            $str = '';
888        }
889        elsif ($line =~ /^\s/)
890        {
891            #  Line which must not be reformatted
892            $str .= "\n" if length ($str) && $str !~ /\n$/;
893            $str .= $line."\n";
894        }
895        else
896        {
897            #  Continuation line, remove newline
898            $str .= " " if length ($str) && $str !~ /[\n ]$/;
899            $str .= $line;
900        }
901    }
902
903    $str =~ s/\s*$//;
904    push(@list, $str) if length ($str);
905
906    return @list;
907}
908
Note: See TracBrowser for help on using the repository browser.