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, 2003 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.26";
  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 <<_EOF_;
 128 ${PROGRAM} (${PACKAGE}) $VERSION
 129 Copyright (C) 2000, 2003 Free Software Foundation, Inc.
 130 Written by Kenneth Christiansen, 2000.
 131
 132 This is free software; see the source for copying conditions.  There is NO
 133 warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 134 _EOF_
 135     exit;
 136 }
 137
 138 ## Sub for printing usage information
 139 sub help {
 140     print <<_EOF_;
 141 Usage: ${PROGRAM} [OPTION]... [FILENAME]
 142 Generates a header file from an XML source file.
 143
 144 It grabs all strings between <_translatable_node> and its end tag in
 145 XML files. Read manpage (man ${PROGRAM}) for more info.
 146
 147       --type=TYPE   Specify the file type of FILENAME. Currently supports:
 148                     "gettext/glade", "gettext/ini", "gettext/keys"
 149                     "gettext/rfc822deb", "gettext/schemas",
 150                     "gettext/scheme", "gettext/xml"
 151   -l, --local       Writes output into current working directory
 152                     (conflicts with --update)
 153       --update      Writes output into the same directory the source file
 154                     reside (conflicts with --local)
 155   -v, --version     Output version information and exit
 156   -h, --help        Display this help and exit
 157   -q, --quiet       Quiet mode
 158
 159 Report bugs to http://bugzilla.gnome.org/ (product name "$PACKAGE")
 160 or send email to <xml-i18n-tools\@gnome.org>.
 161 _EOF_
 162     exit;
 163 }
 164
 165 ## Sub for printing error messages
 166 sub error{
 167     print STDERR "Try `${PROGRAM} --help' for more information.\n";
 168     exit;
 169 }
 170
 171 sub message {
 172     print "Generating C format header file for translation.\n" unless $QUIET_ARG;
 173 }
 174
 175 sub extract {
 176     &determine_type;
 177
 178     &convert ($FILE);
 179
 180     open OUT, ">$OUTFILE";
 181     &msg_write;
 182     close OUT;
 183
 184     print "Wrote $OUTFILE\n" unless $QUIET_ARG;
 185 }
 186
 187 sub convert($) {
 188
 189     ## Reading the file
 190     {
 191         local (*IN);
 192         local $/; #slurp mode
 193         open (IN, "<$FILE") || die "can't open $FILE: $!";
 194         $input = <IN>;
 195     }
 196
 197     &type_ini if $gettext_type eq "ini";
 198     &type_keys if $gettext_type eq "keys";
 199     &type_xml if $gettext_type eq "xml";
 200     &type_glade if $gettext_type eq "glade";
 201     &type_scheme if $gettext_type eq "scheme";
 202     &type_schemas  if $gettext_type eq "schemas";
 203     &type_rfc822deb  if $gettext_type eq "rfc822deb";
 204 }
 205
 206 sub entity_decode_minimal
 207 {
 208     local ($_) = @_;
 209
 210     s/&apos;/'/g; # '
 211     s/&quot;/"/g; # "
 212     s/&amp;/&/g;
 213
 214     return $_;
 215 }
 216
 217 sub entity_decode
 218 {
 219     local ($_) = @_;
 220
 221     s/&apos;/'/g; # '
 222     s/&quot;/"/g; # "
 223     s/&amp;/&/g;
 224     s/&lt;/</g;
 225     s/&gt;/>/g;
 226
 227     return $_;
 228 }
 229
 230 sub escape_char
 231 {
 232     return '\"' if $_ eq '"';
 233     return '\n' if $_ eq "\n";
 234     return '\\' if $_ eq '\\';
 235
 236     return $_;
 237 }
 238
 239 sub escape
 240 {
 241     my ($string) = @_;
 242     return join "", map &escape_char, split //, $string;
 243 }
 244
 245 sub type_ini {
 246     ### For generic translatable desktop files ###
 247     while ($input =~ /^_.*=(.*)$/mg) {
 248         $messages{$1} = [];
 249     }
 250 }
 251
 252 sub type_keys {
 253     ### For generic translatable mime/keys files ###
 254     while ($input =~ /^\s*_\w+=(.*)$/mg) {
 255         $messages{$1} = [];
 256     }
 257 }
 258
 259 sub type_xml {
 260     ### For generic translatable XML files ###
 261
 262     while ($input =~ /\s_$w+\s*=\s*\"([^"]+)\"/sg) { # "
 263         $messages{entity_decode_minimal($1)} = [];
 264     }
 265
 266     while ($input =~ /<_($w+)(?: xml:space="($w+)")?>(.+?)<\/_\1>/sg) {
 267         $_ = $3;
 268         if (!defined($2) || $2 ne "preserve") {
 269             s/\s+/ /g;
 270             s/^ //;
 271             s/ $//;
 272         }
 273         $messages{entity_decode_minimal($_)} = [];
 274     }
 275 }
 276
 277 sub type_schemas {
 278     ### For schemas XML files ###
 279
 280     # FIXME: We should handle escaped < (less than)
 281     while ($input =~ /
 282                       <locale\ name="C">\s*
 283                           (<default>\s*(.*?)\s*<\/default>\s*)?
 284                           (<short>\s*(.*?)\s*<\/short>\s*)?
 285                           (<long>\s*(.*?)\s*<\/long>\s*)?
 286                       <\/locale>
 287                      /sgx) {
 288         my @totranslate = ($2,$4,$6);
 289         foreach (@totranslate) {
 290             next if !$_;
 291         s/\s+/ /g;
 292         $messages{entity_decode_minimal($_)} = [];
 293         }
 294     }
 295 }
 296
 297 sub type_rfc822deb {
 298     ### For rfc822-style Debian configuration files ###
 299
 300     while ($input =~ /(?:^|\n)_[^:]+:\s*(.*?)(?=\n\S|$)/sg) {
 301         my @str_list = rfc822deb_split($1);
 302         for my $str (@str_list) {
 303             #   As rfc822deb is for configuration files, duplicates
 304             #   should never happen.  Developers must use the
 305             #   [] construct to make msgid unique, see also intltool-merge
 306             print STDERR "Warning: msgid multiply defined:\n  $str\n"
 307                 if defined($messages{$str});
 308             $messages{$str} = [];
 309         }
 310     }
 311 }
 312
 313 sub rfc822deb_split {
 314     # Debian defines a special way to deal with rfc822-style files:
 315     # when a value contain newlines, it consists of
 316     #   1.  a short form (first line)
 317     #   2.  a long description, all lines begin with a space,
 318     #       and paragraphs are separated by a single dot on a line
 319     # This routine returns an array of all paragraphs, and reformat
 320     # them.
 321     my $text = shift;
 322     $text =~ s/^ //mg;
 323     return ($text) if $text !~ /\n/;
 324
 325     $text =~ s/([^\n]*)\n//;
 326     my @list = ($1);
 327     my $str = '';
 328     for my $line (split (/\n/, $text)) {
 329         chomp $line;
 330         $line =~ /\s+$/;
 331         if ($line =~ /^\.$/) {
 332             #  New paragraph
 333             $str =~ s/\s*$//;
 334             push(@list, $str);
 335             $str = '';
 336         } elsif ($line =~ /^\s/) {
 337             #  Line which must not be reformatted
 338             $str .= "\n" if length ($str) && $str !~ /\n$/;
 339             $str .= $line."\n";
 340         } else {
 341             #  Continuation line, remove newline
 342             $str .= " " if length ($str) && $str !~ /[\n ]$/;
 343             $str .= $line;
 344         }
 345     }
 346     $str =~ s/\s*$//;
 347     push(@list, $str) if length ($str);
 348     return @list;
 349 }
 350
 351 sub type_glade {
 352     ### For translatable Glade XML files ###
 353
 354     my $tags = "label|title|text|format|copyright|comments|preview_text|tooltip|message";
 355
 356     while ($input =~ /<($tags)>([^<]+)<\/($tags)>/sg) {
 357         # Glade sometimes uses tags that normally mark translatable things for
 358         # little bits of non-translatable content. We work around this by not
 359         # translating strings that only includes something like label4 or window1.
 360         $messages{entity_decode($2)} = [] unless $2 =~ /^(window|label)[0-9]+$/;
 361     }
 362
 363     while ($input =~ /<items>(..[^<]*)<\/items>/sg) {
 364         for my $item (split (/\n/, $1)) {
 365             $messages{entity_decode($item)} = [];
 366         }
 367     }
 368
 369     ## handle new glade files
 370     while ($input =~ /<(property|atkproperty)\s+[^>]*translatable\s*=\s*"yes"[^>]*>([^<]+)<\/\1>/sg) {
 371         $messages{entity_decode($2)} = [] unless $2 =~ /^(window|label)[0-9]+$/;
 372     }
 373     while ($input =~ /<atkaction\s+action_name="([^>]*)"\s+description="([^>]+)"\/>/sg) {
 374         $messages{entity_decode_minimal($2)} = [];
 375     }
 376 }
 377
 378 sub type_scheme {
 379     while ($input =~ /_\w*\(?"((?:[^"\\]+|\\.)*)"\)?/sg) {
 380         $messages{$1} = [];
 381     }
 382 }
 383
 384 sub msg_write {
 385     for my $message (sort keys %messages) {
 386         print OUT "/* xgettext:no-c-format */\n" if $message =~ /%/;
 387
 388         my @lines = split (/\n/, $message, -1);
 389         for (my $n = 0; $n < @lines; $n++) {
 390             if ($n == 0) {
 391                 print OUT "char *s = N_(\"";
 392             } else {
 393                 print OUT "             \"";
 394             }
 395
 396             print OUT escape($lines[$n]);
 397
 398             if ($n < @lines - 1) {
 399                 print OUT "\\n\"\n";
 400             } else {
 401                 print OUT "\");\n";
 402             }
 403         }
 404     }
 405 }
 406