package require TclOO
package require msgcat

# 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 $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]]
}

namespace eval ::msgcat {
    namespace export mcmsetto oomc
}

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
        }
    }
}

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"
    }
}

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