~nandhp/nandhp-freecell/freecell-translations-1.5

#!/usr/bin/perl
#
# translate-rc.pl - Translate .RC files using gettext-compatible .PO files.
#
# This script extracts localizable messages from the .RC files and puts
# them in a .POT file. It then runs gettext's msgmerge program to
# update the LANG.PO files, and generates translated .RC files from
# those .PO files.
#
# A very recent version of Perl (at least 5.8) is required for this
# script.
#
# translate-rc.pl
# Copyright (c) 2009 nandhp <nandhp@gmail.com>
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions
# are met:
#
# 1. Redistributions of source code must retain the above copyright
# notice, this list of conditions and the following disclaimer.
#
# 2. Redistributions in binary form must reproduce the above copyright
# notice, this list of conditions and the following disclaimer in the
# documentation and/or other materials provided with the distribution.
#
# 3. Neither the names of the authors nor the names of their
# contributors may be used to endorse or promote products derived from
# this software without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
# "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
# LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS
# FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
# COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
# BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
# LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
# CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
# ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#

use constant VERSION => 0.1;

# Configuration ###############################################################

# Indicate paths to each input .RC file, the context prefix (to allow
# for multiple .RC files), and translated output .RC file. All paths
# are relative to the project directory. The template files must be
# UTF-8. The output .RC files are UTF-16.
my @rcfiles = (
	       [ 'PlatIndependent/FreeCell.rc' => 'PlatIndependent'
	         => 'PlatIndependent/%s.rc' ],
	       [ 'PocketPC/FreeCell.rc' => 'PocketPC'
	         => 'PocketPC/%s.rc' ],
	       #[ 'AppInst/en.nsh' => 'Setup' => 'AppInst/%s.nsh' ],
	      );

# Directory where the translation files will be stored.
my $PODIR = 'po';
# The name of translation template .POT file in that directory.
my $DOMAIN = 'freecell.pot';

# Main Program ################################################################

# TODO: Read translation-template content-type from the file itself.

# Load program modules
use Encode qw/encode decode/;
use File::Compare;
use POSIX qw/strftime/;
use warnings;
use strict;

# String format definitions
my $I = '[^\s,/#]';
my $rcS = '(?:L?"(?:|.*?(?<!")(?:"")*)"(?!"))';
my $poS = '(?:\s*"(|.*?(?<!\\\\)(?:\\\\\\\\)*)"\s*)';
# Beware of excessively-doubled backslashes

my $POTFILE = "$PODIR/$DOMAIN";

# List of languages to update. msgmerge will be run for each of these
# languages, then a .RC file will be generated.
my @langs = LoadLanguages();

# Read the translation template, preserving order, comments, and
# translations.
my %template = ();
my $templateorder = 0;
my %item = ();
# Load language template file (first one), then pull translations for
# .RC files from other files.
foreach my $lang ( $DOMAIN, @langs ) {
    my $C = $lang eq $DOMAIN;
    my $file = $C ? $POTFILE : "$PODIR/$lang.po";
    (warn("Skipping nonexistant file $file\n"),next) unless -f $file;
    open F, '<', $file or warn "Can't read $file: $!";
    my $mode = '';
    foreach (<F>, '#') {
	s/\r//g unless $_ eq '#'; # Remove \r, will be (re)added later
	if ( m/^#/ and exists($item{$lang}) ) {
	    my $item = $item{_ctxt}||'';
	    if ( $C ) {			# Install new string
		$templateorder++;
		$item{_templateorder} = $templateorder;
		$item{_obsolete} = 0;	# Change to 1 to enable obsoleting
		foreach ( keys %item ) {
		    $template{$item}{$_} = $item{$_};
		}
	    }
	    elsif ( exists($template{$item}) ) {
		$template{$item}{$lang} = $item{$lang};
	    }
	    %item = ();
	}
	# Parse special comments into %item.
	if ( $_ eq '#' ) { last }	# File ending comment
	elsif ( m/^#[\s\.]/ and $C ) {	# Extracted comments
	    $item{_comment} = '' unless exists($item{_comment});
	    $item{_comment} .= $_;
	}
	elsif ( m/^#\s/ ) { next }	# Translator's comments
	elsif ( m/^#:/ ) { next } 	# Reference comment (use context)
	elsif ( m/^#\|/ ) { next }	# Previous translation comment
	elsif ( m/^(msg(ctxt|id|str)\s)?(?:$poS)$/ ) {
	    if ( $1 ) { $mode = $2 }
	    my $str = $3;		  # From inside $poS
	    my $key = '';
	    if ( $mode eq 'id' ) { $key = '_msgid' } # Original string
	    elsif ( $mode eq 'ctxt' ) { $key = '_ctxt' } # Message context
	    elsif ( $mode eq 'str' ) { $key = $lang }	 # Local translation
	    $item{$key} = '' unless exists($item{$key});
	    $item{$key} .= $str;
	}
    }
    close F;
}
# Ignore missing .RC files
{ my $i = 0; while ( exists($rcfiles[$i]) ) {
    ($i++,next) if -f $rcfiles[$i][0];
    warn "Skipping nonexistant file $rcfiles[$i][0]\n";
    splice @rcfiles, $i, 1;
} }
# Loop over the .RC files
foreach my $rcfile ( @rcfiles ) {
    # Index the .RC file, looking for new or changed messages, while
    # outputting translated .RC files.
    open F, '<', $rcfile->[0] or warn "Can't read $rcfile->[0]: $!";
    my %rcoutputs = ();
    foreach my $lang ( @langs ) {
	$rcoutputs{$lang} = "#ifdef APSTUDIO_INVOKED\r\n#error This file is an automatically generated translation and should not be edited directly.\r\n#endif\r\n\r\n";
    }
    my $lastrcid = '';
    while (<F>) {
	if ( m/,\s*$/ ) { $_ .= <F> }
	if ( m/^\s*($I+)\s+(ACCELERATORS|BITMAP|CURSOR|DIALOG(EX)?|FONT|HTML|ICON|MENU(EX)?|MESSAGETABLE|POPUP|RCDATA|STRINGTABLE|VERSIONINFO)\s/ or
	     m/^\s*(STRINGTABLE)\s+/ ) { $lastrcid = $1 }
	elsif ( (m/^\s*($I+)\s+($rcS)[,\s]+($I+)/ and $1 ne 'VALUE')
	      or m/^\s*(CAPTION|POPUP)\s+($rcS)/ or
		($lastrcid eq 'STRINGTABLE' and m/^\s*(?:!define\s+)?($I+)\s+($rcS)/) ) {
	    my ($type,$value,$id) = ($1,$2,$3);
	    if ( $id ) { }
	    elsif ( $lastrcid eq 'STRINGTABLE' )
	      { $id = $type; $type = $lastrcid }
	    elsif ( $type eq 'CAPTION' ) { $id = '__CAPTION__' }
	    elsif ( $type eq 'POPUP' )
	      { $id = $value; $id =~ tr/a-z /A-Z_/; $id =~ tr/_/_/s;
		$id =~ s/[^0-9A-Z_]//g; $id = '__POPUP_'.$id }
	    my $name = "$rcfile->[1]:$lastrcid.$id";
	    if ( !exists($template{$name}) ) {
		$template{$name}{_ctxt} = $name;
		$template{$name}{_comment} = "#. Automatically detected $type item in $lastrcid\n";
		$templateorder++;
		$template{$name}{_templateorder} = $templateorder;
		$template{$name}{$DOMAIN} = '';
		$template{$name}{_obsolete} = 1;
		$template{$name}{_msgid} = rc2po($value);
		$template{$name}{_obsolete} = 0 if $template{$name}{_msgid};
	    }
	    else {
		$template{$name}{_msgid} = rc2po($value);
		$template{$name}{_obsolete} = 0;
	    }
	    foreach my $lang ( keys %rcoutputs ) {
		my $t = $_;
		$t =~ s/$rcS/po2rc($template{$name}{$lang})/e
		  if exists($template{$name}{$lang}) and
		    $template{$name}{$lang};
		$rcoutputs{$lang} .= $t;
	    }
	    next; 			# Skip language-neutral output routine
	}
	elsif ( m/^\s*#\s*include\s+($rcS)/ ) {
	    foreach my $lang ( keys %rcoutputs ) {
		my $t = $_;
		my $orig = $1;
		$orig =~ s/^L?"//g; $orig =~ s/"$//g;
		foreach my $repl ( @rcfiles ) {
		    next unless $orig eq $repl->[0];
		    my $new = sprintf($repl->[2],$lang);
		    $t =~ s/$rcS/"$new"/;
		    $orig = $new;
		}
		$rcoutputs{$lang} .= $t;
	    }
	    next;
	}
	foreach my $lang ( keys %rcoutputs ) {
	    $rcoutputs{$lang} .= $_;
	}
    }
    foreach my $lang ( keys %rcoutputs ) {
	my $file = sprintf($rcfile->[2], $lang);
	# .RC files must be UTF-16 Unicode for .RC to recognize them
	# as Unicode. (NOTE: Not sure if this is true)
	open F, '>:raw', "$file.new"
	  or warn "Can't write $file: $!";
	print F encode('UTF-16LE',"\x{feff}".decode('UTF-8',$rcoutputs{$lang}));
	close F;
	OverwriteIfChanged($file, "$file.new");
    }
}

# Fill in default template
if ( !exists($template{''}) ) {
    # Fill in default template
    $template{''}{_comment} = "# SOME DESCRIPTIVE TITLE.\n# Copyright (C) YEAR OF THE PACKAGE'S COPYRIGHT HOLDER\n# This file is distributed under the same license as the PACKAGE package.\n# FIRST AUTHOR <EMAIL\@ADDRESS>, YEAR.\n# \n#, fuzzy\n";
    $template{''}{_ctxt} = '';
    $template{''}{_msgid} = '';
    $template{''}{$DOMAIN} = 'Project-Id-Version: PACKAGE VERSION\nReport-Msgid-Bugs-To: \nPOT-Creation-Date: YEAR-MO-DA HO:MI+ZONE\nPO-Revision-Date: YEAR-MO-DA HO:MI+ZONE\nLast-Translator: FULL NAME <EMAIL@ADDRESS>\nLanguage-Team: LANGUAGE <LL@li.org>\nMIME-Version: 1.0\nContent-Type: text/plain; charset=UTF-8\nContent-Transfer-Encoding: 8bit\n';
    $template{''}{_templateorder} = 0;
}
# Update POT-Creation-Date.
my $now = strftime('%Y-%m-%d %H:%M%z', localtime);
$template{''}{$DOMAIN} =~ s/(POT-Creation-Date:).*?(\\n)/$1 $now$2/;

# Output new template file
my @keys = sort { $template{$a}{_templateorder}
		    <=> $template{$b}{_templateorder} } keys %template;
open F, '>', "$POTFILE.new" or warn "Can't write $POTFILE: $!";
foreach my $key ( @keys ) {
    next if $template{$key}{_obsolete};
    my $s = $template{$key}{_comment} .
      ($template{$key}{_ctxt} ?
       ('msgctxt ' . poquote($template{$key}{_ctxt})) : '') .
	'msgid ' . poquote($template{$key}{_msgid}) .
	  'msgstr ' . poquote($template{$key}{$DOMAIN}) ."\n";
    #$s =~ s/\n/\r\n/g;			# Not supported by gettext
    print F $s;
}
close F;
OverwriteIfChanged($POTFILE, "$POTFILE.new");

# Run msgmerge
foreach my $lang ( @langs ) {
    print "Running msgmerge on $lang.po...\n";
    system 'msgmerge', '-U', '-q', "$PODIR/$lang.po", $POTFILE;
}

# Get a list of .PO files in $PODIR, stripping off the .po suffix.
sub LoadLanguages {
    my @list = ();
    opendir DIR, $PODIR or warn "Can't list $PODIR: $!";
    foreach ( readdir DIR ) {
	if ( -f "$PODIR/$_" and $_ =~ m/^([-_a-zA-Z]+)\.po$/ ) {
	    push @list, $1;
	}
    }
    closedir DIR;
    return @list;
}

# Compare old and new files. If different, replace old with new. If
# same, delete new.
sub OverwriteIfChanged {
    my ($old, $new) = @_;
    if ( compare($old, $new) != 0 ) {
	rename $new, $old or warn "Can't replace $old: $!";
	print "Replacing $old...\n";
    }
    else { unlink $new }
}

# Convert rc-file quoting to po-file quoting.  Specifically, '""' for
# '"' becomes '\"'
sub rc2po {
    my ($arg) = @_;
    $arg =~ s/^L?"//;
    $arg =~ s/\"$//;
    $arg =~ s/\"\"/\"/g;
    return $arg;
}

# Convert po-file quoting to rc-file quoting. Specifically, '\"' for
# '"' becomes '""'.
sub po2rc {
    my ($arg) = @_;
    $arg =~ s/\\"/""/g;
    return "\"$arg\"";
}

# Quote a string for storage in a po-file: If it contains '\n', split
# it across lines at those points.
sub poquote {
    my ($arg) = @_;
    $arg =~ s/(\\n)/$1"\n"/g and $arg = "\"\n\"$arg";
    $arg = "\"$arg\"\n";
    $arg =~ s/\n""\n/\n/;
    return $arg;
}