msgcat-Ready Script Utility

EKB: This is a small GUI utility for taking an existing script and making it "msgcat-ready".

It does this by:

Looking for each unique string (delimited by "") and asking whether it should be put in the message catalog
Creating a new copy of the script with any msgcat-strings wrapped in [mc...]
Creating or appending to a .msg file in a "msgs" subfolder (the subfolder is created if need be, and new strings are appended if the file already exists)
Adding code at the top of the new script to load the messages and also to discover the locale from either the environment (Unix) or registry (Windows)

EKB 2008-01-20: The script has been thoroughly updated and debugged.

A limitation of the utility is that it will only find strings in quotation marks. Since, in Tcl, everything is a string, trying to identify unquoted strings or strings in curly braces gives too many false positives. The assumption is that most natural-language strings will be quoted in "", and that any other strings can be added to the message catalog relatively quickly by hand.

Here's what it looks like:

To use it,

Type in the language of the original script
Click on the "..." button and browse for the script
Click on "Get Strings" to fill in the list of strings
Check off the strings that need translating
Click on the "Run" button to generate the files
Look in the same folder/directory as the original script to find the generated files

Code

Here's the script (NOL - no obligation license):

##############################################################
#
# Copyright 2005-2008 Eric Kemp-Benedict
#
# No-obligation license: No obligation to you, no obligation
#   to me.
#
# Transform a script into a msgcat-ready alternative
# Wrap strings in [mc ] and export a properly-formatted
# list.
#
##############################################################

#------------------------------------------------------
#
# A slightly spiced-up checkbutton for convenience
#
#------------------------------------------------------

namespace eval qstring {
    variable vals
    variable len 30
}


proc qstring::checkstring {w s} {
    variable len

    frame $w
    checkbutton $w.cb -variable qstring::vals($s) -text $s -bg white \
        -font fixed -selectcolor white -width $len -anchor w \
        -command "qstring::togglecolor $w.cb"
    set qstring::vals($s) false
    
    pack $w.cb
}


proc qstring::togglecolor w {
    if {[$w cget -bg] eq {white}} {
        $w config -bg gray80
        $w config -selectcolor gray80
    } else {
        $w config -bg white
        $w config -selectcolor white
    }
}


proc qstring::clearall {} {
    variable vals
    
    array unset vals
}


proc qstring::setlen {{newlen {}}} {
    variable len
    
    if {$newlen ne {} {
        set len $newlen
    }
    
    return $len
}


proc qstring::strings {} {
    variable vals
    
    return [array names vals]
}


proc qstring::ignore s {
    variable vals
    
    if [info exists vals($s)] {
        set retval [expr {!$vals($s)}]
    } else {
        set retval true
    }
    
    return $retval
}

#------------------------------------------------------
#
# Create the basic interface
#
#------------------------------------------------------

set deflang en
set infile {}

# Specify language
frame .lang
pack .lang -side top -anchor w
label .lang.l -text "Starting Language: "
pack .lang.l -side left
entry .lang.e -textvariable deflang -width 10
pack .lang.e -side left

# Browse for file
frame .file
pack .file -side top -anchor w -fill x -expand yes
label .file.l -text "File: "
pack .file.l -side left
entry .file.e -textvariable infile
pack .file.e -side left -fill x -expand yes
button .file.browse -text ... -command findfile
pack .file.browse -side left -padx 2


proc findfile {} {
    set defdir [file dirname $::infile]
    set types {
        {{Tcl Scripts}       {.tcl}        }
        {{All files}         {.*}          }
    }
    
    set fname [tk_getOpenFile -initialdir $defdir -filetypes $types]
    
    if {$fname ne {}} {
        set ::infile $fname
    }
}

# Run!
frame .buttons
pack .buttons -side top
button .buttons.getstr -text {Get Strings} -command getstrings -width 9
pack .buttons.getstr -side left -padx 2
button .buttons.run -text "Run" -command run -width 9
pack .buttons.run -padx 2

# A place to put strings
frame .strings -height 300
pack .strings -side bottom -fill both -expand yes
scrollbar .strings.sb -command {.strings.l yview}
pack .strings.sb -side right -fill y
text .strings.l -yscrollcommand {.strings.sb set} -cursor arrow -width 65
pack .strings.l -side left -fill both -expand yes


proc getstrings {} {
    # First clear out old strings
    .strings.l delete 1.0 end
    qstring::clearall
    
    set infp [open $::infile r]
    
    while {[gets $infp currline] != -1} {
        # Is this a comment? Print it and just keep going
        if {[regexp -- {^\s*#} $currline] == 1} {
            continue
        }
        set splitline [split $currline \"]
        set isstring false
        foreach fragment $splitline {
            if {$isstring} {
                if [info exists strings($fragment)] {
                    set isstring false
                    continue
                }
                set strings($fragment) 1
                set isstring false
            } else {
                set isstring true
            }
        }
    }
    close $infp
    
    qstring::setlen [.strings.l cget -width]
    set i 0
    foreach s [array names strings] {
        qstring::checkstring .strings.l.s$i $s
        .strings.l window create end -window .strings.l.s$i
        incr i
    }
}


proc run {} {
    set newfile "[file rootname $::infile]_l10n.tcl"
    file mkdir [file join [file dirname $::infile] msgs]
    set mcatfile [file join [file dirname $::infile] msgs $::deflang.msg]
    
    set infp [open $::infile r]
    set newfp [open $newfile w]
    
    puts $newfp "package require msgcat"
    puts $newfp "namespace import msgcat::mc"
    puts $newfp "\n# Set default locale, then try to get from environment or (in Windows) registry"
    puts $newfp "msgcat::mclocale $::deflang"
    puts $newfp {
if [info exists ::env(LANG)] {
    msgcat::mclocale $::env(LANG)
} else {
    if {[string match -nocase Windows* $::tcl_platform(os)] && ![catch {package require registry}]} {
        if {![catch {registry get {HKEY_CURRENT_USER\Control Panel\International} sLanguage} res]} {
            msgcat::mclocale [string tolower [string range $res 0 1]]
        }
    }
}
}
    # NOTE: Put the .msg files into a "msgs" folder under the script
    # If this particular file isn't there, then revert to default
    set cmd {if {![msgcat::mcload [file join [file dirname [info script]] msgs]]}}
    puts $newfp "$cmd {\n\tmsgcat::mclocale $::deflang\n\tmsgcat::mcload \[file join \[file dirname \[info script\]\] msgs\]\n}"
    puts $newfp {} 
    
    while {[gets $infp currline] != -1} {
        # Is this a comment? Print it and just keep going
        if {[regexp -- {^\s*#} $currline] == 1} {
            puts $newfp $currline
            continue
        }
        set splitline [split $currline \"]
        set outline {}
        # Assume (!!) first part of the line is not a quote.
        set isstring false
        foreach fragment $splitline {
            if {$isstring} {
                # If not ignoring, then it's an acceptable string
                if [qstring::ignore $fragment] {
                    set outline "$outline\"$fragment\""
                } else {
                    set outline "$outline\[mc \"$fragment\"\]"
                }
                # Toggle - next fragment not a string
                set isstring false
            } else {
                set outline "$outline$fragment"
                set isstring true
            }
        }
        puts $newfp $outline
    }
    
    close $infp
    close $newfp
    
    if [file exists $mcatfile] {
        set mcfp [open $mcatfile a]
    } else {
        set mcfp [open $mcatfile w]
        puts $mcfp "namespace import -force msgcat::mcset\n"
        puts $mcfp "set lang $::deflang\n"
    }
    
    puts $mcfp "# From \"[file tail $::infile]\":"
    foreach mcstring [lsort [qstring::strings]] {
        if {![qstring::ignore $mcstring]} {
            puts $mcfp "mcset \$lang \\\n\t{$mcstring} \\\n\t{$mcstring}\n"
        }
    }
    
    close $mcfp
}

Example

Here's an example. I took RS's A little sluice simulation and passed it through. Choosing only the strings that needed translating, this gave a default (English-language) .msg file (which is automatically saved under a "msgs" folder):

namespace import -force msgcat::mcset

set lang en

# From "RSSluiceSim.tcl":
mcset $lang \
    {Can't open gate - water not level} \
    {Can't open gate - water not level}

mcset $lang \
    {Can't open valve when gate still open} \
    {Can't open valve when gate still open}

mcset $lang \
    {Close} \
    {Close}

mcset $lang \
    {Open} \
    {Open}

mcset $lang \
    {Welcome to the sluice simulation! (Hint: open the right valve)} \
    {Welcome to the sluice simulation! (Hint: open the right valve)}

mcset $lang \
    {sluice simulator} \
    {sluice simulator}

and a new script (named OLDNAME_l10n.tcl, if the name of the original script was OLDNAME.tcl):

package require msgcat
namespace import msgcat::mc

# Set default locale, then try to get from environment or (in Windows) registry
msgcat::mclocale en

if [info exists ::env(LANG)] {
    msgcat::mclocale $::env(LANG)
} else {
    if {[string match -nocase Windows* $::tcl_platform(os)]
        && ![catch {package require registry}]} {

        if {![catch {
            registry get \
            {HKEY_CURRENT_USER\Control Panel\International} \
            sLanguage
        } res]} {
            msgcat::mclocale [string tolower [string range $res 0 1]]
        }
    }
}

if {![msgcat::mcload [file join [file dirname [info script]] msgs]]} {
      msgcat::mclocale en
      msgcat::mcload [file join [file dirname [info script]] msgs]
}

wm title . [mc {sluice simulator}]
pack [label .info -textvar info -anchor w] -side bottom -fill x
set info [mc "Welcome to the sluice simulation! (Hint: open the right valve)"]
pack [canvas .c -width 600 -height 280 -bg lightblue]

.c create polygon 0 300  0 90  450 90  600 120  600 300 -fill green3
.c create polygon 140 300 140 80 460 80 460 300 -fill grey
.c create polygon 150 250 150 80 450 80 450 250 -fill grey60

.c create rect 150  80  153 150 -fill brown  -tag gate1
.c create rect 151  80  152  60 -fill black  -tag gate1
.c create rect 135  60  168  40 -fill yellow -tag gate1
.c create text 151  50  -text Gate1          -tag {gate1 txt}
set isOpen(gate1) 0
.c bind gate1 <1>  {toggleGate .c gate1}
bind    .     <F5> {toggleGate .c gate1}

.c create rect 450  80  453 250 -fill brown  -tag gate2
.c create rect 451  80  452  60 -fill black  -tag gate2
.c create rect 435  60  468  40 -fill yellow -tag gate2
.c create text 451  50  -text "Gate2"        -tag {gate2 txt}
set isOpen(gate2) 0
.c bind gate2 <1>  {toggleGate .c gate2}
bind    .     <F8> {toggleGate .c gate2}

c create polygon 0 152 0 100 150 100 150 152 -fill blue1\
  -tag {water upriver} -stipple gray50
c create polygon 452 250 452 200 600 200 600 250 -fill blue1 \
  -stipple gray50 -tag {water downriver}
c create polygon 150 100 150 250 452 250 452 100 -fill blue1 \
  -tag {water sluicewater sluiced} -stipple gray50
c create line 90 150 90 160 100 170 150 170 -width 5 -fill blue1 \
  -smooth 1 -tag water
c create polygon 140 290 140 250 460 250 460 290 -fill grey -tag water

.c create oval 110 160 130 180 -fill white -tag {valve1 water}
.c create rect 118 160 122 180 -fill grey  -tag {valve1 valve1r water}
set isOpen(valve1r) 0
.c bind valve1 <1>  {toggleValve .c valve1r}
bind    .      <F6> {toggleValve .c valve1r}

.c create line 420 250 420 260 430 270 480 270 490 265 490 250 \
   -width 5 -fill blue1 -smooth 1 -tag fg
.c create oval 450 260 470 280 -fill white -tag valve2
.c create rect 458 260 462 280 -fill grey  -tag {valve2 valve2r}
set isOpen(valve2r) 0
.c bind valve2 <1>  {toggleValve .c valve2r}
bind    .      <F7> {toggleValve .c valve2r}


proc lpick list {lindex $list [expr {int(rand()*[llength $list])}]}


proc Cabin {} {
  set c [lpick {red yellow green blue SteelBlue1 magenta}]
}


proc Cargo {} {
  set c [lpick {wheat bisque sienna4 chocolate3 "indian red" goldenrod1 PaleVioletRed1}]
}


proc boat w {
  $w create poly 10 90 10 77 50 77 50 90    -fill [Cabin] -tag {boat cabin}
  $w create rect 8 78 52 75  -fill grey  -tag boat
  $w create rect 13 86 23 79 -fill white -tag boat
  $w create rect 28 86 38 79 -fill white -tag boat
  $w create poly 0 90  0 95  203 95  205 90 -fill white -tag boat
  $w create poly 0 95  0 125  5 130  200 130  203 95 \
      -fill black -tag boat
 #$w create poly 50 90 90 80 130 90 160 80 200 90\
 #    -fill bisque -outline black -tag boat
  $w create poly 50 90 90 80 130 90 160 80 200 90\
      -fill [Cargo] -outline black -tag {boat cargo}
  $w move boat 160 0
  $w lower boat water
  set ::moveBoat 0
  set ::boatDirection 1
}

boat .c


proc toggleGate {w tag} {
    global info isOpen moveBoat boatDirection
    if {
        $tag eq {gate1} && [maxy $w sluicewater]>[maxy $w upriver]
        ||
        $tag eq {gate2} && [maxy $w sluicewater]<[maxy $w downriver]
    } {
        set info [mc {Can't open gate - water not level}]
        return
    }
    set T "$tag && txt"
    $w itemconfig $T -text [expr {$isOpen($tag)? [mc Open]: [mc Close]}]
  
    foreach {x0 y0 x1 y1} [$w coords $tag] break
    set x0 [expr {$x0 + ($isOpen($tag)? 50 : -50)}]
    $w coords $tag $x0 $y0 $x1 $y1
    set isOpen($tag) [expr {1-$isOpen($tag)}]
    set info "$tag [expr {$isOpen($tag)? {opened} : {closed}}]"
    foreach {bx0 by0 bx1 by1} [$w bbox boat] break
    if {$bx1<100*$boatDirection || $bx0<460*$boatDirection} {
        set moveBoat 0
    }
    if {$isOpen($tag)} {set moveBoat [expr $boatDirection*2]}
}


proc toggleValve {w tag} {
    global isOpen
    if {!$isOpen($tag) && ($isOpen(gate1) || $isOpen(gate2))} {
        set ::info [mc {Can't open valve when gate still open}]
        return
    }
    foreach {x0 y0 x1 y1} [$w coords $tag] break
    set dx2 [expr {($x1-$x0)/2.}]
    set mx  [expr {($x0+$x1)/2}]
    set dy2 [expr {($y1-$y0)/2.}]
    set my  [expr {($y0+$y1)/2}]
    set isOpen($tag) [expr {$dx2<$dy2}]
    $w itemconfig $tag -fill [expr {$isOpen($tag)? {blue1}: {grey}}]
    $w coords $tag [expr {$mx-$dy2}] [expr {$my-$dx2}] [
        expr {$mx+$dy2}] [expr {$my+$dx2}]
    set ::info "$tag [expr {$::isOpen($tag)? {opened} : {closed}}]"
}


proc every {ms body} {eval $body; after $ms [namespace code [info level 0]]}


proc maxy {w tag} {lindex [$w bbox $tag] 1}


proc animate w {
    global moveBoat isOpen
    foreach {bx0 by0 bx1 by1} [$w bbox boat]        break
    foreach {sx0 top sx1 sy1} [$w bbox sluicewater] break
    if {$bx0 > $sx0 && $bx1 < $sx1} {
        $w addtag sluiced withtag boat
        if {$bx1>390 && $bx0<460 && $moveBoat>0 && !$isOpen(gate2)} {
            set moveBoat 0
        }
        if {$bx0<160 && $bx1>90 && $moveBoat<0 && !$isOpen(gate1)} {
            set moveBoat 0
        }
    } else {
        $w dtag boat sluiced
        if {$bx0<470 && $bx0>150 && $moveBoat<0 && !$isOpen(gate2) \
          || $bx1>100 && $bx1<450 && $moveBoat>0 && !$isOpen(gate1)} {
            set moveBoat 0
        }
    }
    if {$top<[maxy $w downriver] && $isOpen(valve2r)} {
        $w move sluiced 0 1
        set moveBoat 0
    }
    if {$top>[maxy $w upriver] && $isOpen(valve1r)} {
        $w move sluiced 0 -1
        set moveBoat 0
    }
    $w move boat $moveBoat 0
  
    # Check if boat has left our view:
    if {$bx0>700} {
        bell  ;# 'New' boat
        .c itemconfig cabin  -fill [Cabin]
        .c itemconfig cargo  -fill [Cargo]
        if {rand()>0.5} {
            $w scale boat [expr {($bx0+$bx1)/2}] $by0 -1 1
            set moveBoat -2; set ::boatDirection -1
        } else {$w move boat -1000 -100}
    }
    if {$bx0<-300} {
        bell  ;# 'New' boat
        .c itemconfig cabin  -fill [Cabin]
        .c itemconfig cargo  -fill [Cargo]
        if {rand()>0.5} {
            $w scale boat [expr {($bx0+$bx1)/2}] $by0 -1 1
            set moveBoat 2; set ::boatDirection 1
        } else {$w move boat 1000 100}
    }
}

every 100 {animate .c}
wm resizable . 0 0
focus -force .c

# Test:
bind . <F1> { wm title . [.c bbox boat] }
bind . <F2> { console show }

Next I made a translation in my not-so-good French (I really really don't know if I got the right translation for "sluice" in this case) and saved it as "fr.msg" in the "msgs" folder:

namespace import -force msgcat::mcset

set lang fr

# From "RSSluiceSim.tcl":
mcset $lang \
    {Can't open gate - water not level} \
    {Impossible d'ouvrir la porte - le niveau de l'eau n'est pas le même}

mcset $lang \
    {Can't open valve when gate still open} \
    {Impossible d'ouvrir la valve lorsque la porte est encore ouverte}

mcset $lang \
    {Close} \
    {Fermez}

mcset $lang \
    {Open} \
    {Ouvrez}

mcset $lang \
    {Welcome to the sluice simulation! (Hint: open the right valve)} \
    {Bienvenu à la simulation de l'écluse! (Suggestion: ouvrez la valve à droite)}

mcset $lang \
    {sluice simulator} \
    {simulation de l'écluse}

Then in Windows I changed my locale by going to "Control Panel | Region and Language Options" and setting the language on the Regional Options tab to "French (France)". Here's the result:

MG: Without having actually tried this, I think it's a really nice idea. Personally, I never code for msgcat-translations when I write a script (apart from in menus, for some reason) and have to go through and find it all afterwards to translate, if it's needed. One (very minor) criticism/suggestion, having looked at it briefly, though - you should be able to pass the language on the command line, as well as the file name to fix, IMHO (with it still defaulting to US English), to save having to constantly edit this script.

EKB: Thanks! The GUI version now does this.

RZ: It is often a tedious work to create and maintain *.msg files. With the following procedure it will be a little bit easier. Write all text strings in your source code as "[mc ...]". The namespace will be found with the last line starting with "namespace eval .." in the file. Only one namespace per file is used. Then call the following function with all your files. Existing translations from the old de.msg file will be used. No more used translations are removed.

proc do files { 
    package require msgcat
    source msgs/de.msg;# use existing translations
    set myEn "# en.msg\n";# assumption, original texts are in english
    set myDe "# de.msg\n";# german translation example
    foreach myFile $files {
        # read source file
        set myFd [open $myFile r]
        set myC [read $myFd]
        close $myFd
        append myEn "# $myFile\n"
        append myDe "# $myFile\n"
        # find namespace
        set myNs [lindex [regexp -inline -line -all -- \
            {^namespace\s+eval\s+[[:graph:]]+\s} $myC] end]
        if {$myNs eq {}} {set myNs {namespace eval ::}}
        # put translations in namespace
        append myEn "$myNs {\n"
        append myDe "$myNs {\n"
        set myList [list]
        # find existing translations
        foreach myMc [regexp -inline -all -- {(\[mc\s.*\]){1,1}?} $myC] {
            lappend myList [lindex [string trim $myMc {[]}] 1]
        }
        # create englich and german translation
        foreach myMc [lsort -unique $myList] {
            append myEn "::msgcat::mcset en {$myMc}\n"
            {*}$myNs "set ::my \[[list ::msgcat::mc $myMc]\]"
            append myDe "::msgcat::mcset de {$myMc} {$::my}\n"
        }
        append myEn "}\n"
        append myDe "}\n"
    }
    # write translation files
    puts msgs/en.msg $myEn
    puts msgs/de.msg $myDe
}

Category Local