source: trunk/third/gnome-system-monitor/intltool-merge.in @ 18394

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