msgcat and TclOO

Eric Boudaillier, 2014-02-06: While msgcat is designed to work with namespace, the following code allows using msgcat in conjunction with TclOO. The code is based on msgcat, and adds two new commands:

msgcat::msmsetto, to define messages translations in a specified folder.
msgcat::oomc, to get message inside a method.

Eric Boudaillier, 2017-12-08: Code updated to work with msgcat >= 1.6. See below for older code.

package require TclOO
package require msgcat

namespace eval ::msgcat {
    namespace export mcmsetto oomc
}

# This procedure returns the class hierarchy of an object.
proc ::msgcat::OOTraversal {class {lvar ""}} {
    if {$lvar ne ""} {
        upvar 1 $lvar l
    }
    lappend l $class
    foreach parent [info class superclasses $class] {
        if {$parent ne "::oo::object" && $parent ni $l} {
            OOTraversal $parent l
        }
    }
    return $l
}

# mcmsetto is like mcmset, but with a specified folder instead
# of caller namespace.
# This allow defining messages associated to a class.
proc ::msgcat::mcmsetto {folder locale pairs} {
    variable Msgs

    if {![string match "::*" $folder]} {
        # Relative to current namespace
        set ns [uplevel 1 {namespace current}]
        if {$ns eq "::"} {
            set folder "::$folder"
        } else {
            set folder "${ns}::$folder"
        }
    }
    set length [llength $pairs]
    if {$length % 2} {
        return -code error "bad translation list:\
                 should be \"[lindex [info level 0] 0] folder locale {src dest ...}\""
    }

    set locale [string tolower $locale]
    foreach {src dest} $pairs {
        dict set Msgs $folder $locale $src $dest
    }

    return [expr {$length / 2}]
}

# Copy of msgcat::mc, but search in class hierarchy,
# then class namespace hierarchy.
proc ::msgcat::oomc {src args} {
    variable Msgs
    variable Loclist

    # Get object class hierarchy
    set obj [uplevel 1 self]
    if {[info object isa class $obj]} {
        set class $obj
    } else {
        set class [info object class $obj]
    }
    set folders [OOTraversal $class]

    # Add namespace hierarchy
    set ns [regsub {::[^:]*$} $class ""]
    if {$ns eq ""} {set ns "::"}
    while {$ns ne ""} {
        lappend folders $ns
        set ns [namespace parent $ns]
    }

    foreach ns $folders {
        foreach loc $Loclist {
            if {[dict exists $Msgs $ns $loc $src]} {
                if {[llength $args] == 0} {
                    return [dict get $Msgs $ns $loc $src]
                } else {
                    return [format [dict get $Msgs $ns $loc $src] {*}$args]
                }
            }
        }
    }

    # we have not found the translation
    return [uplevel 1 [list ::msgcat::mcunknown \
            "" $src {*}$args]]
}

Older implementation for msgcat < 1.6 (mcmsetto and oomc only):

# mcmsetto is like mcmset, but with a specified folder instead
# of caller namespace.
# This allow defining messages associated to a class.
proc ::msgcat::mcmsetto {folder locale pairs} {
    variable Msgs

    if {![string match "::*" $folder]} {
        # Relative to current namespace
        set ns [uplevel 1 {namespace current}]
        if {$ns eq "::"} {
            set folder "::$folder"
        } else {
            set folder "${ns}::$folder"
        }
    }
    set length [llength $pairs]
    if {$length % 2} {
        return -code error "bad translation list:\
                 should be \"[lindex [info level 0] 0] folder locale {src dest ...}\""
    }

    set locale [string tolower $locale]
    foreach {src dest} $pairs {
        dict set Msgs $locale $folder $src $dest
    }

    return [expr {$length / 2}]
}

# Copy of msgcat::mc, but search in class hierarchy,
# then class namespace hierarchy.
proc ::msgcat::oomc {src args} {
    variable Msgs
    variable Loclist
    variable Locale

    # Get object class hierarchy
    set obj [uplevel 1 self]
    if {[info object isa class $obj]} {
        set class $obj
    } else {
        set class [info object class $obj]
    }
    set folders [OOTraversal $class]

    # Add namespace hierarchy
    set ns [regsub {::[^:]*$} $class ""]
    if {$ns eq ""} {set ns "::"}
    while {$ns ne ""} {
        lappend folders $ns
        set ns [namespace parent $ns]
    }

    foreach ns $folders {
        foreach loc $Loclist {
            if {[dict exists $Msgs $loc $ns $src]} {
                if {[llength $args] == 0} {
                    return [dict get $Msgs $loc $ns $src]
                } else {
                    return [format [dict get $Msgs $loc $ns $src] {*}$args]
                }
            }
        }
    }

    # we have not found the translation
    return [uplevel 1 [list ::msgcat::mcunknown \
            $Locale $src {*}$args]]
}

Here is a simple package:

namespace import ::msgcat::*

namespace eval MyPkg {
    # Base class Alpha
    oo::class create Alpha {
        method testFooMsg {} {
            oomc FooMsg
        }
        method testBarMsg {} {
            oomc BarMsg
        }
    }

    # Derived class Beta
    oo::class create Beta {
        superclass Alpha
    }

    # Another class Gamma
    oo::class create Gamma {
        method testFooMsg {} {
            oomc FooMsg
        }
        method testBarMsg {} {
            oomc BarMsg
        }
    }
}

The messages can be defined in another file (a .msg file), without needing the class to be defined.

namespace eval MyPkg {
    mcmset {} {
        FooMsg "this is my package foo msg"
    }
    mcmsetto Alpha {} {
        FooMsg "this is the alpha foo msg"
        BarMsg "this is the alpha bar msg"
    }
    mcmsetto Beta {} {
        FooMsg "this is the beta foo msg"
    }
}

And the result:

set a [MyPkg::Alpha new]
set b [MyPkg::Beta new]
set g [MyPkg::Gamma new] 

$a testFooMsg => this is the alpha foo msg
$a testBarMsg => this is the alpha bar msg
$b testFooMsg => this is the beta foo msg
$b testBarMsg => this is the alpha bar msg
$g testFooMsg => this is my package foo msg
$g testBarMsg => BarMsg

DKF: It seems to me like we don't need all that much code to make this work:

namespace eval ::msgcat {
    oo::class create MessageCatalogAware {
        forward mc       ::msgcat::OOBridge ::msgcat::mc
        forward mcmax    ::msgcat::OOBridge ::msgcat::mcmax
        forward mcexists ::msgcat::OOBridge ::msgcat::mcexists
        # Tricky point: methods are not usefully callable from outside the class hierarchy
        unexport mc mcmax mcexists
    }

    proc OOBridge {cmd args} {
        if {[catch {
            # Tricky point: [self class] needs to run in the caller
            set ns [namespace qualifiers [uplevel 1 {self class}]]
        }]} {
            # Not a class-defined method (so we got an error); use instance instead
            set ns [namespace qualifiers [uplevel 1 self]]
        }
        tailcall apply [list {cmd args} {tailcall $cmd {*}$args} $ns] $cmd
    }
}

(Note that the tricky bits are self class and a tailcall/apply/tailcall chain.)

(Random user: I am loathe to change this without testing, but surely it should be tailcall apply list {cmd args} {tailcall $cmd {*}$args} $ns $cmd {*}$args?)

Then I'd just do something like this while using all the usual mechanisms for setting up the message catalog, with derived classes in their own package using their own catalogs for the methods they define:

namespace eval MyPkg {
    # Base class Alpha
    oo::class create Alpha {
        mixin ::msgcat::MessageCatalogAware
        method testFooMsg {} {
            my mc FooMsg
        }
        method testBarMsg {} {
            my mc BarMsg
        }
    }

    # Derived class Beta
    oo::class create Beta {
        superclass Alpha
    }
}

msgcat

TclOO