git.hungrycats.org Git - xscreensaver/blob - 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