#--------------------------------------------------------------------------------------------------------
# Language translation package
#
# Example:
#
# our $LanguageFile = "$0.language";
# require 'Language.pl';
# ...
# die Translate("<Translate this string> but not this one\n");
#
# Ideally, all strings will be <translated> except for system provided messages.
#--------------------------------------------------------------------------------------------------------

# Declare and set up the message translate hash.
my %Language;
LoadLanguage();

# Format and possibly translate a message. All <translatable portions>
# are translated and everything else is left as-is.
# This is called with printf like arguments.
sub Translate
    {
    my $format = shift;
    my $text = sprintf($format, @_);
    my $update = 0;

    # Scan the string for <translatable text>
    while ($text =~ /<(.*?)>/)
        {

        # Remember if we add a new one so we can update the file
        if (not exists $Language{$1})
            {
            $update = 1;
            $Language{$1} = $1;
            }
        $text = "$`$Language{$1}$'";
        }

    # Update the translation file, if necessary
    UpdateLanguageFile(%Language) if $update;

    # Return the translated message
    $text;
    }

# Load or create the translation file and translation table
sub LoadLanguage
    {
    %Language = ();

    # If we can open the file, just read the translations.
    if (open(LANGUAGEFILE, '<', $_ = $LanguageFile))
        {
        my $message;

        # Look for Message: and Says: lines.
        while (<LANGUAGEFILE>)
            {
            chomp;
            $message = $1            if /^\s*English:\s*(.*)/;
            $Language{$message} = $1 if /^\s*Says:\s*(.*)/;
            }
        close LANGUAGEFILE;
        return;
        }

    # The file does not exist. Scan this program for translatable strings.
    if (open(ME, '<', $_ = $0))
        {
        # Scan this script for calls to Translate with <translatable strings>.
        while (<ME>)
            {
            while (s/(Translate\s*\(.*)<(.*?)>(.*)\)/$1$2$3/)
                {
#               warn qq(Warning: duplicate translated text: "$2"\n) if exists $Language{$2};
                $Language{$2} = $2;
                }
            }
        close ME;
        UpdateLanguageFile(%Language);
        }
    }

# Update the language file with the current translation strings.
sub UpdateLanguageFile
    {
    return unless open(LANGUAGEFILE, '>', $LanguageFile);

    print LANGUAGEFILE "# This file translates messages. It must be pairs of lines.\n";
    print LANGUAGEFILE "# The first line must say English: and then have the message from\n";
    print LANGUAGEFILE "# the program exactly. The second line must say Says: and then have\n";
    print LANGUAGEFILE "# any message you would like to actually see.\n";
    print LANGUAGEFILE "\n";
    print LANGUAGEFILE "# Delete this file and run the program again to get all default messages.\n";
    print LANGUAGEFILE "\n";

    my %messages = @_;
    foreach (sort {"\U$a" cmp "\U$b"} keys %messages)
        {
        print LANGUAGEFILE "English: $_\n";
        print LANGUAGEFILE "Says:    $messages{$_}\n";
        print LANGUAGEFILE "\n";
        }

    close LANGUAGEFILE;
    }

# Success
1;
