From http://www.jwz.org/xscreensaver/xscreensaver-5.29.tar.gz
[xscreensaver] / intltool-extract.in
1 #!@INTLTOOL_PERL@ -w 
2 # -*- Mode: perl; indent-tabs-mode: nil; c-basic-offset: 4  -*-
3
4 #
5 #  The Intltool Message Extractor
6 #
7 #  Copyright (C) 2000-2001 Free Software Foundation.
8 #
9 #  Intltool is free software; you can redistribute it and/or
10 #  modify it under the terms of the GNU General Public License as
11 #  published by the Free Software Foundation; either version 2 of the
12 #  License, or (at your option) any later version.
13 #
14 #  Intltool is distributed in the hope that it will be useful,
15 #  but WITHOUT ANY WARRANTY; without even the implied warranty of
16 #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
17 #  General Public License for more details.
18 #
19 #  You should have received a copy of the GNU General Public License
20 #  along with this program; if not, write to the Free Software
21 #  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
22 #
23 #  As a special exception to the GNU General Public License, if you
24 #  distribute this file as part of a program that contains a
25 #  configuration script generated by Autoconf, you may include it under
26 #  the same distribution terms that you use for the rest of that program.
27 #
28 #  Authors: Kenneth Christiansen <kenneth@gnu.org>
29 #           Darin Adler <darin@bentspoon.com>
30 #
31
32 ## Release information
33 my $PROGRAM      = "intltool-extract";
34 my $PACKAGE      = "intltool";
35 my $VERSION      = "0.18";
36
37 ## Loaded modules
38 use strict; 
39 use File::Basename;
40 use Getopt::Long;
41
42 ## Scalars used by the option stuff
43 my $TYPE_ARG    = "0";
44 my $LOCAL_ARG   = "0";
45 my $HELP_ARG    = "0";
46 my $VERSION_ARG = "0";
47 my $UPDATE_ARG  = "0";
48 my $QUIET_ARG   = "0";
49
50 my $FILE;
51 my $OUTFILE;
52
53 my $gettext_type = "";
54 my $input;
55 my %messages = ();
56
57 ## Use this instead of \w for XML files to handle more possible characters.
58 my $w = "[-A-Za-z0-9._:]";
59
60 ## Always print first
61 $| = 1;
62
63 ## Handle options
64 GetOptions (
65             "type=s"     => \$TYPE_ARG,
66             "local|l"    => \$LOCAL_ARG,
67             "help|h"     => \$HELP_ARG,
68             "version|v"  => \$VERSION_ARG,
69             "update"     => \$UPDATE_ARG,
70             "quiet|q"    => \$QUIET_ARG,
71             ) or &error;
72
73 &split_on_argument;
74
75
76 ## Check for options. 
77 ## This section will check for the different options.
78
79 sub split_on_argument {
80
81     if ($VERSION_ARG) {
82         &version;
83
84     } elsif ($HELP_ARG) {
85         &help;
86         
87     } elsif ($LOCAL_ARG) {
88         &place_local;
89         &extract;
90
91     } elsif ($UPDATE_ARG) {
92         &place_normal;
93         &extract;
94
95     } elsif (@ARGV > 0) {
96         &place_normal;
97         &message;
98         &extract;
99
100     } else {
101         &help;
102
103     }  
104 }    
105
106 sub place_normal {
107     $FILE        = $ARGV[0];
108     $OUTFILE     = "$FILE.h";
109 }   
110
111 sub place_local {
112     $OUTFILE     = fileparse($FILE, ());
113     if (!-e "tmp/") { 
114         system("mkdir tmp/"); 
115     }
116     $OUTFILE     = "./tmp/$OUTFILE.h"
117 }
118
119 sub determine_type {
120    if ($TYPE_ARG =~ /^gettext\/(.*)/) {
121         $gettext_type=$1
122    }
123 }
124
125 ## Sub for printing release information
126 sub version{
127     print "${PROGRAM} (${PACKAGE}) $VERSION\n";
128     print "Copyright (C) 2000 Free Software Foundation, Inc.\n";
129     print "Written by Kenneth Christiansen, 2000.\n\n";
130     print "This is free software; see the source for copying conditions. There is NO\n";
131     print "warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.\n";
132     exit;
133 }
134
135 ## Sub for printing usage information
136 sub help{
137     print "Usage: ${PROGRAM} [FILENAME] [OPTIONS] ...\n";
138     print "Generates a header file from an xml source file.\n\nGrabs all strings ";
139     print "between <_translatable_node> and it's end tag,\nwhere tag are all allowed ";
140     print "xml tags. Read the docs for more info.\n\n"; 
141     print "  -v, --version                shows the version\n";
142     print "  -h, --help                   shows this help page\n";
143     print "  -q, --quiet                  quiet mode\n";
144     print "\nReport bugs to <kenneth\@gnu.org>.\n";
145     exit;
146 }
147
148 ## Sub for printing error messages
149 sub error{
150     print "Try `${PROGRAM} --help' for more information.\n";
151     exit;
152 }
153
154 sub message {
155     print "Generating C format header file for translation.\n";
156 }
157
158 sub extract {
159     &determine_type;
160
161     &convert ($FILE);
162
163     open OUT, ">$OUTFILE";
164     &msg_write;
165     close OUT;
166
167     print "Wrote $OUTFILE\n" unless $QUIET_ARG;
168 }
169
170 sub convert($) {
171
172     ## Reading the file
173     {
174         local (*IN);
175         local $/; #slurp mode
176         open (IN, "<$FILE") || die "can't open $FILE: $!";
177         $input = <IN>;
178     }
179
180     &type_ini if $gettext_type eq "ini";
181     &type_keys if $gettext_type eq "keys";
182     &type_xml if $gettext_type eq "xml";
183     &type_glade if $gettext_type eq "glade";
184     &type_scheme if $gettext_type eq "scheme";
185 }
186
187 sub entity_decode_minimal
188 {
189     local ($_) = @_;
190
191     s/&apos;/'/g; # '
192     s/&quot;/"/g; # "
193     s/&amp;/&/g;
194
195     return $_;
196 }
197
198 sub entity_decode
199 {
200     local ($_) = @_;
201
202     s/&apos;/'/g; # '
203     s/&quot;/"/g; # "
204     s/&amp;/&/g;
205     s/&lt;/</g;
206     s/&gt;/>/g;
207
208     return $_;
209 }
210
211 sub escape_char
212 {
213     return '\"' if $_ eq '"';
214     return '\n' if $_ eq "\n";
215     return '\\' if $_ eq '\\';
216
217     return $_;
218 }
219
220 sub escape
221 {
222     my ($string) = @_;
223     return join "", map &escape_char, split //, $string;
224 }
225
226 sub type_ini {
227     ### For generic translatable desktop files ###
228     while ($input =~ /^_.*=(.*)$/mg) {
229         $messages{$1} = [];
230     }
231 }
232
233 sub type_keys {
234     ### For generic translatable mime/keys files ###
235     while ($input =~ /^\s*_\w+=(.*)$/mg) {
236         $messages{$1} = [];
237     }
238 }
239
240 sub type_xml {
241     ### For generic translatable XML files ###
242         
243     while ($input =~ /\s_$w+=\"([^"]+)\"/sg) { # "
244         $messages{entity_decode_minimal($1)} = [];
245     }
246
247     while ($input =~ /<_($w+)>(.+?)<\/_\1>/sg) {
248         $_ = $2;
249         s/\s+/ /g;
250         s/^ //;
251         s/ $//;
252         $messages{entity_decode_minimal($_)} = [];
253     }
254 }
255
256 sub type_glade {
257     ### For translatable Glade XML files ###
258
259     my $tags = "label|title|text|format|copyright|comments|preview_text|tooltip|message";
260
261     while ($input =~ /<($tags)>([^<]+)<\/($tags)>/sg) {
262         # Glade sometimes uses tags that normally mark translatable things for
263         # little bits of non-translatable content. We work around this by not
264         # translating strings that only includes something like label4 or window1.
265         $messages{entity_decode($2)} = [] unless $2 =~ /^(window|label)[0-9]+$/;
266     }
267     
268     while ($input =~ /<items>(..[^<]*)<\/items>/sg) {
269         for my $item (split (/\n/, $1)) {
270             $messages{entity_decode($item)} = [];
271         }
272     }
273
274     ## handle new glade files
275     while ($input =~ /<(property|atkproperty)\s+[^>]*translatable\s*=\s*"yes"[^>]*>([^<]+)<\/\1>/sg) {
276         $messages{entity_decode($2)} = [] unless $2 =~ /^(window|label)[0-9]+$/;
277     }
278
279 }
280
281 sub type_scheme {
282     while ($input =~ /_\(?"((?:[^"\\]+|\\.)*)"\)?/sg) {
283         $messages{$1} = [];
284     }
285 }
286
287 sub msg_write {
288     for my $message (sort keys %messages) { 
289         print OUT "/* xgettext:no-c-format */\n" if $message =~ /%/;
290         
291         my @lines = split (/\n/, $message);
292         for (my $n = 0; $n < @lines; $n++) {
293             if ($n == 0) { 
294                 print OUT "char *s = N_(\""; 
295             } else {  
296                 print OUT "             \""; 
297             }
298
299             print OUT escape($lines[$n]);
300
301             if ($n < @lines - 1) { 
302                 print OUT "\\n\"\n"; 
303             } else { 
304                 print OUT "\");\n";  
305             }
306         }
307     }
308 }
309