Implement TIP 490: msgcat for TclOO

6 files changed, 296 insertions, 38 deletions

diff --git a/changes b/changes
index f89704b..5b5a93e 100644
--- a/changes
+++ b/changes
@@ -8879,3 +8879,5 @@ in this changeset (new minor version) rather than bug fixes:
 2017-09-02 (bug)[0e4d88] replace command, delete trace kills namespace (porter)
 
 --- Released 8.7a1, September 8, 2017 --- http://core.tcl.tk/tcl/ for details
+
+2017-12-11 (TIP 490) add oo support for msgcat => msgcat 1.7.0 (oehlmann)
diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl
index 646bc17..203a1bf 100644
--- a/library/msgcat/msgcat.tcl
+++ b/library/msgcat/msgcat.tcl
@@ -11,15 +11,16 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
-package require Tcl 8.5-
+package require Tcl 8.6-
 # When the version number changes, be sure to update the pkgIndex.tcl file,
 # and the installation directory in the Makefiles.
-package provide msgcat 1.6.1
+package provide msgcat 1.7.0
 
 namespace eval msgcat {
-    namespace export mc mcexists mcload mclocale mcmax mcmset mcpreferences mcset\
+    namespace export mc mcn mcexists mcload mclocale mcmax\
+	    mcmset mcpreferences mcset\
             mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\
-	    mcpackageconfig mcpackagelocale
+	    mcpackagenamespaceget mcpackageconfig mcpackagelocale
 
     # Records the list of locales to search
     variable Loclist {}
@@ -192,10 +193,30 @@ namespace eval msgcat {
 #	Returns the translated string.  Propagates errors thrown by the
 #	format command.
 
-proc msgcat::mc {src args} {
-    # this may be replaced by:
-    # return [mcget -namespace [uplevel 1 [list ::namespace current]] --\
-    #	    $src {*}$args]
+proc msgcat::mc {args} {
+    tailcall mcn [PackageNamespaceGet] {*}$args
+}
+
+# msgcat::mcn --
+#
+#	Find the translation for the given string based on the current
+#	locale setting. Check the passed namespace first, then look in each
+#	parent namespace until the source is found.  If additional args are
+#	specified, use the format command to work them into the traslated
+#	string.
+#	If no catalog item is found, mcunknown is called in the caller frame
+#	and its result is returned.
+#
+# Arguments:
+#	ns	Package namespace of the translation
+#	src	The string to translate.
+#	args	Args to pass to the format command
+#
+# Results:
+#	Returns the translated string.  Propagates errors thrown by the
+#	format command.
+
+proc msgcat::mcn {ns src args} {
 
     # Check for the src in each namespace starting from the local and
     # ending in the global.
@@ -203,7 +224,6 @@ proc msgcat::mc {src args} {
     variable Msgs
     variable Loclist
 
-    set ns [uplevel 1 [list ::namespace current]]
     set loclist [PackagePreferences $ns]
 
     set nscur $ns
@@ -219,7 +239,7 @@ proc msgcat::mc {src args} {
     # call package local or default unknown command
     set args [linsert $args 0 [lindex $loclist 0] $src]
     switch -exact -- [Invoke unknowncmd $args $ns result 1] {
-	0 { return [uplevel 1 [linsert $args 0 [namespace origin mcunknown]]] }
+	0 { tailcall mcunknown {*}$args }
 	1 { return [DefaultUnknown {*}$args] }
 	default { return $result }
     }
@@ -245,23 +265,31 @@ proc msgcat::mcexists {args} {
     variable Loclist
     variable PackageConfig
 
-    set ns [uplevel 1 [list ::namespace current]]
-    set loclist [PackagePreferences $ns]
-
     while {[llength $args] != 1} {
 	set args [lassign $args option]
 	switch -glob -- $option {
-	    -exactnamespace { set exactnamespace 1 }
-	    -exactlocale { set loclist [lrange $loclist 0 0] }
+	    -exactnamespace - -exactlocale { set $option 1 }
+	    -namespace {
+		if {[llength $args] < 2} {
+		    return -code error\
+			    "Argument missing for switch \"-namespace\""
+		}
+		set args [lassign $args ns]
+	    }
 	    -* { return -code error "unknown option \"$option\"" }
 	    default {
 		return -code error "wrong # args: should be\
 			\"[lindex [info level 0] 0] ?-exactnamespace?\
-			?-exactlocale? src\""
+			?-exactlocale? ?-namespace ns? src\""
 	    }
 	}
     }
     set src [lindex $args 0]
+    
+    if {![info exists ns]} { set ns [PackageNamespaceGet] }
+
+    set loclist [PackagePreferences $ns]
+    if {[info exists -exactlocale]} { set loclist [lrange $loclist 0 0] }
 
     while {$ns ne ""} {
 	foreach loc $loclist {
@@ -269,7 +297,7 @@ proc msgcat::mcexists {args} {
 		return 1
 	    }
 	}
-	if {[info exists exactnamespace]} {return 0}
+	if {[info exists -exactnamespace]} {return 0}
 	set ns [namespace parent $ns]
     }
     return 0
@@ -462,7 +490,7 @@ proc msgcat::mcpackagelocale {subcommand {locale ""}} {
 	}
         set locale [string tolower $locale]
     }
-    set ns [uplevel 1 {::namespace current}]
+    set ns [PackageNamespaceGet]
 
     switch -exact -- $subcommand {
 	get { return [lindex [PackagePreferences $ns] 0] }
@@ -551,7 +579,7 @@ proc msgcat::mcforgetpackage {} {
     # todo: this may be implemented using an ensemble
     variable PackageConfig
     variable Msgs
-    set ns [uplevel 1 {::namespace current}]
+    set ns [PackageNamespaceGet]
     # Remove MC items
     dict unset Msgs $ns
     # Remove config items
@@ -561,6 +589,15 @@ proc msgcat::mcforgetpackage {} {
     return
 }
 
+# msgcat::mcgetmynamespace --
+#
+#	Return the package namespace of the caller
+#	This consideres to be called from a class or object.
+
+proc msgcat::mcpackagenamespaceget {} {
+    return [PackageNamespaceGet]
+}
+
 # msgcat::mcpackageconfig --
 #
 #	Get or modify the per caller namespace (e.g. packages) config options.
@@ -616,7 +653,7 @@ proc msgcat::mcforgetpackage {} {
 proc msgcat::mcpackageconfig {subcommand option {value ""}} {
     variable PackageConfig
     # get namespace
-    set ns [uplevel 1 {::namespace current}]
+    set ns [PackageNamespaceGet]
 
     if {$option ni {"mcfolder" "loadcmd" "changecmd" "unknowncmd"}} {
 	return -code error "bad option \"$option\": must be mcfolder, loadcmd,\
@@ -756,8 +793,7 @@ proc msgcat::ListComplement {list1 list2 {inlistname ""}} {
 #	Returns the number of message catalogs that were loaded.
 
 proc msgcat::mcload {langdir} {
-    return [uplevel 1 [list\
-	    [namespace origin mcpackageconfig] set mcfolder $langdir]]
+    tailcall mcpackageconfig set mcfolder $langdir
 }
 
 # msgcat::LoadAll --
@@ -923,7 +959,7 @@ proc msgcat::mcset {locale src {dest ""}} {
 	set dest $src
     }
 
-    set ns [uplevel 1 [list ::namespace current]]
+    set ns [PackageNamespaceGet]
 
     set locale [string tolower $locale]
 
@@ -951,7 +987,7 @@ proc msgcat::mcflset {src {dest ""}} {
 	return -code error "must only be used inside a message catalog loaded\
 		with ::msgcat::mcload"
     }
-    return [uplevel 1 [list [namespace origin mcset] $FileLocale $src $dest]]
+    tailcall mcset $FileLocale $src $dest
 }
 
 # msgcat::mcmset --
@@ -975,7 +1011,7 @@ proc msgcat::mcmset {locale pairs} {
     }
 
     set locale [string tolower $locale]
-    set ns [uplevel 1 [list ::namespace current]]
+    set ns [PackageNamespaceGet]
 
     foreach {src dest} $pairs {
 	dict set Msgs $ns $locale $src $dest
@@ -1002,7 +1038,7 @@ proc msgcat::mcflmset {pairs} {
 	return -code error "must only be used inside a message catalog loaded\
 		with ::msgcat::mcload"
     }
-    return [uplevel 1 [list [namespace origin mcmset] $FileLocale $pairs]]
+    tailcal mcmset $FileLocale $pairs
 }
 
 # msgcat::mcunknown --
@@ -1024,7 +1060,7 @@ proc msgcat::mcflmset {pairs} {
 #	Returns the translated value.
 
 proc msgcat::mcunknown {args} {
-    return [uplevel 1 [list [namespace origin DefaultUnknown] {*}$args]]
+    tailcall DefaultUnknown {*}$args
 }
 
 # msgcat::DefaultUnknown --
@@ -1067,8 +1103,9 @@ proc msgcat::DefaultUnknown {locale src args} {
 
 proc msgcat::mcmax {args} {
     set max 0
+    set ns [PackageNamespaceGet]
     foreach string $args {
-	set translated [uplevel 1 [list [namespace origin mc] $string]]
+	set translated [uplevel 1 [list [namespace origin mcn] $ns $string]]
 	set len [string length $translated]
 	if {$len>$max} {
 	    set max $len
@@ -1106,6 +1143,38 @@ proc msgcat::ConvertLocale {value} {
     return $ret
 }
 
+# helper function to find package namespace of stack-frame -2
+# There are 4 possibilities:
+# - called from a proc
+# - called within a class definition script
+# - called from an class defined oo object
+# - called from a classless oo object
+proc ::msgcat::PackageNamespaceGet {} {
+    uplevel 2 {
+	# Check for no object
+	switch -exact -- [namespace which self] {
+	    {::oo::define::self} {
+		# We are within a class definition
+		return [namespace qualifiers [self]]
+	    }
+	    {::oo::Helpers::self} {
+		# We are within an object
+		set Class [info object class [self]]
+		# Check for classless defined object
+		if {$Class eq {::oo::object}} {
+		    return [namespace qualifiers [self]]
+		}
+		# Class defined object
+		return [namespace qualifiers $Class]
+	    }
+	    default {
+		# Not in object environment
+		return [namespace current]
+	    }
+	}
+    }
+}
+  
 # Initialize the default locale
 proc msgcat::Init {} {
     global env
diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl
index 72c5dc0..74a284f 100644
--- a/library/msgcat/pkgIndex.tcl
+++ b/library/msgcat/pkgIndex.tcl
@@ -1,2 +1,3 @@
-if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
-package ifneeded msgcat 1.6.1 [list source [file join $dir msgcat.tcl]]
+if {![package vsatisfies [package provide Tcl] 8.5]} {return}
+if {![package vsatisfies [package provide Tcl] 8.6-]} {return}
+package ifneeded msgcat 1.7.0 [list source [file join $dir msgcat.tcl]]
diff --git a/tests/msgcat.test b/tests/msgcat.test
index 1c3ce58..7f872ed 100644
--- a/tests/msgcat.test
+++ b/tests/msgcat.test
@@ -688,7 +688,7 @@ namespace eval ::msgcat::test {
 	test msgcat-9.1 {mcexists no parameter} -body {
 	    mcexists
 	} -returnCodes 1\
-	-result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? src"}
+	-result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? ?-namespace ns? src"}
 
 	test msgcat-9.2 {mcexists unknown option} -body {
 	    mcexists -unknown src
@@ -724,12 +724,34 @@ namespace eval ::msgcat::test {
 	    mcset foo k1 v1
 	} -cleanup {
 	    mclocale $locale
+	    namespace delete ::foo
 	} -body {
-	    namespace eval ::msgcat::test::sub {
+	    namespace eval ::foo {
 		list [::msgcat::mcexists k1]\
-			[::msgcat::mcexists -exactnamespace k1]
+			[::msgcat::mcexists -namespace ::msgcat::test k1]
 	    }
-	} -result {1 0}
+	} -result {0 1}
+
+	test msgcat-9.6 {mcexists -namespace ns parameter} -setup {
+	    mcforgetpackage
+	    variable locale [mclocale]
+	    mclocale foo_bar
+	    mcset foo k1 v1
+	} -cleanup {
+	    mclocale $locale
+	    namespace delete ::foo
+	} -body {
+	    namespace eval ::foo {
+		list [::msgcat::mcexists k1]\
+			[::msgcat::mcexists -namespace ::msgcat::test k1]
+	    }
+	} -result {0 1}
+
+	test msgcat-9.7 {mcexists -namespace - ns argument missing} -body {
+	    mcexists -namespace src
+	} -returnCodes 1\
+	-result {Argument missing for switch "-namespace"}
+
 
     # Tests msgcat-10.*: [mcloadedlocales]
 
@@ -1073,6 +1095,170 @@ namespace eval ::msgcat::test {
 	} -returnCodes 1\
 	-result {fail}
 
+
+    # Tests msgcat-15.*: tcloo coverage
+    
+    # There are 4 use-cases, where 3 must be tested now:
+    # - namespace defined, in class definition, class defined oo, classless
+
+    test msgcat-15.1 {mc in class setup} -setup {
+	# full namespace is ::msgcat::test:bar
+	namespace eval bar {
+	    ::msgcat::mcset foo_BAR con2 con2bar
+	    oo::class create ClassCur
+	}
+	variable locale [mclocale]
+	mclocale foo_BAR
+    } -cleanup {
+	mclocale $locale
+	namespace eval bar {::msgcat::mcforgetpackage}
+	namespace delete bar
+    } -body {
+	oo::define bar::ClassCur msgcat::mc con2
+    } -result con2bar
+
+    test msgcat-15.2 {mc in class} -setup {
+	# full namespace is ::msgcat::test:bar
+	namespace eval bar {
+	    ::msgcat::mcset foo_BAR con2 con2bar
+	    oo::class create ClassCur
+	    oo::define ClassCur method method1 {} {::msgcat::mc con2}
+	}
+	# full namespace is ::msgcat::test:baz
+	namespace eval baz {
+            set ObjCur [::msgcat::test::bar::ClassCur new]
+	}
+	variable locale [mclocale]
+	mclocale foo_BAR
+    } -cleanup {
+	mclocale $locale
+	namespace eval bar {::msgcat::mcforgetpackage}
+	namespace delete bar baz
+    } -body {
+	$baz::ObjCur method1
+    } -result con2bar
+
+    test msgcat-15.3 {mc in classless object} -setup {
+	# full namespace is ::msgcat::test:bar
+	namespace eval bar {
+	    ::msgcat::mcset foo_BAR con2 con2bar
+	    oo::object create ObjCur
+	    oo::objdefine ObjCur method method1 {} {::msgcat::mc con2}
+	}
+	variable locale [mclocale]
+	mclocale foo_BAR
+    } -cleanup {
+	mclocale $locale
+	namespace eval bar {::msgcat::mcforgetpackage}
+	namespace delete bar
+    } -body {
+	bar::ObjCur method1
+    } -result con2bar
+    
+    test msgcat-15.4 {mc in classless object with explicite namespace eval}\
+    -setup {
+	# full namespace is ::msgcat::test:bar
+	namespace eval bar {
+	    ::msgcat::mcset foo_BAR con2 con2bar
+	    oo::object create ObjCur
+	    oo::objdefine ObjCur method method1 {} {
+		namespace eval ::msgcat::test::baz {
+		    ::msgcat::mc con2
+		}
+	    }
+	}
+	namespace eval baz {
+	    ::msgcat::mcset foo_BAR con2 con2baz
+	}
+	variable locale [mclocale]
+	mclocale foo_BAR
+    } -cleanup {
+	mclocale $locale
+	namespace eval bar {::msgcat::mcforgetpackage}
+	namespace eval baz {::msgcat::mcforgetpackage}
+	namespace delete bar baz
+    } -body {
+	bar::ObjCur method1
+    } -result con2baz
+    
+    # Test msgcat-16.*: command mcpackagenamespaceget
+
+    test msgcat-16.1 {mcpackagenamespaceget in namespace procedure} -body {
+	namespace eval baz {msgcat::mcpackagenamespaceget}
+    } -result ::msgcat::test::baz
+
+    test msgcat-16.2 {mcpackagenamespaceget in class setup} -setup {
+	namespace eval bar {
+	    oo::class create ClassCur
+	    oo::define ClassCur variable a
+	}
+    } -cleanup {
+	namespace delete bar
+    } -body {
+	oo::define bar::ClassCur msgcat::mcpackagenamespaceget
+    } -result ::msgcat::test::bar
+
+    test msgcat-16.3 {mcpackagenamespaceget in class} -setup {
+	namespace eval bar {
+	    oo::class create ClassCur
+	    oo::define ClassCur method method1 {} {msgcat::mcpackagenamespaceget}
+	}
+	namespace eval baz {
+            set ObjCur [::msgcat::test::bar::ClassCur new]
+	}
+    } -cleanup {
+	namespace delete bar baz
+    } -body {
+	$baz::ObjCur method1
+    } -result ::msgcat::test::bar
+
+    test msgcat-16.4 {mcpackagenamespaceget in classless object} -setup {
+	namespace eval bar {
+	    oo::object create ObjCur
+	    oo::objdefine ObjCur method method1 {} {msgcat::mcpackagenamespaceget}
+	}
+    } -cleanup {
+	namespace delete bar
+    } -body {
+	bar::ObjCur method1
+    } -result ::msgcat::test::bar
+
+    test msgcat-16.5\
+    {mcpackagenamespaceget in classless object with explicite namespace eval}\
+    -setup {
+	namespace eval bar {
+	    oo::object create ObjCur
+	    oo::objdefine ObjCur method method1 {} {
+		namespace eval ::msgcat::test::baz {
+		    msgcat::mcpackagenamespaceget
+		}
+	    }
+	}
+    } -cleanup {
+	namespace delete bar baz
+    } -body {
+	bar::ObjCur method1
+    } -result ::msgcat::test::baz
+
+
+    # Test msgcat-17.*: mcn command
+    
+    test msgcat-17.1 {mcn no parameters} -body {
+	mcn
+    } -returnCodes 1\
+    -result {wrong # args: should be "mcn ns src ?arg ...?"}
+
+    test msgcat-17.2 {mcn} -setup {
+	namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar}
+	variable locale [mclocale]
+	mclocale foo_BAR
+    } -cleanup {
+	mclocale $locale
+    } -body {
+	::msgcat::mcn [namespace current]::bar con1
+    } -result con1bar
+
+
     interp bgerror {} $bgerrorsaved
 
     cleanupTests
diff --git a/unix/Makefile.in b/unix/Makefile.in
index b91e0ef..9c9ee53 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -851,8 +851,8 @@ install-libraries: libraries
 	    do \
 	    $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \
 	    done;
-	@echo "Installing package msgcat 1.6.1 as a Tcl Module";
-	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.1.tm;
+	@echo "Installing package msgcat 1.7.0 as a Tcl Module";
+	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/msgcat-1.7.0.tm;
 	@echo "Installing package tcltest 2.4.1 as a Tcl Module";
 	@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm;
 
diff --git a/win/Makefile.in b/win/Makefile.in
index 8348924..1a72fc7 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -660,8 +660,8 @@ install-libraries: libraries install-tzdata install-msgs
 	    do \
 	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
 	    done;
-	@echo "Installing package msgcat 1.6.1 as a Tcl Module";
-	@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.6.1.tm;
+	@echo "Installing package msgcat 1.7.0 as a Tcl Module";
+	@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/msgcat-1.7.0.tm;
 	@echo "Installing package tcltest 2.4.0 as a Tcl Module";
 	@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.4.0.tm;
 	@echo "Installing package platform 1.0.14 as a Tcl Module";