Implement TIP 499: Custom locale search list for msgcat

3 files changed, 213 insertions, 59 deletions

diff --git a/changes b/changes
index 5b5a93e..feed968 100644
--- a/changes
+++ b/changes
@@ -8880,4 +8880,7 @@ in this changeset (new minor version) rather than bug fixes:
 
 --- 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)
+2018-03-12 (TIP 490) add oo support for msgcat => msgcat 1.7.0 (oehlmann)
+
+2018-03-12 (TIP 499) custom locale preference list (nijtmans)
+=> msgcat 1.7.0
diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl
index 203a1bf..96b0110 100644
--- a/library/msgcat/msgcat.tcl
+++ b/library/msgcat/msgcat.tcl
@@ -20,7 +20,7 @@ namespace eval msgcat {
     namespace export mc mcn mcexists mcload mclocale mcmax\
 	    mcmset mcpreferences mcset\
             mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\
-	    mcpackagenamespaceget mcpackageconfig mcpackagelocale
+	    mcpackagenamespaceget mcpackageconfig mcpackagelocale mcutil
 
     # Records the list of locales to search
     variable Loclist {}
@@ -42,7 +42,13 @@ namespace eval msgcat {
     # namespace should be themselves dict values and the value is
     # the translated string.
     variable Msgs [dict create]
+}
 
+# create ensemble namespace for mcutil command
+namespace eval msgcat::mcutil {
+    namespace export getsystemlocale getpreferences
+    namespace ensemble create -prefix 0
+    
     # Map of language codes used in Windows registry to those of ISO-639
     if {[info sharedlibextension] eq ".dll"} {
 	variable WinRegToISO639 [dict create  {*}{
@@ -331,32 +337,27 @@ proc msgcat::mclocale {args} {
 	    return -code error "invalid newLocale value \"$newLocale\":\
 		    could be path to unsafe code."
 	}
-	if {[lindex $Loclist 0] ne $newLocale} {
-	    set Loclist [GetPreferences $newLocale]
-
-	    # locale not loaded jet
-	    LoadAll $Loclist
-	    # Invoke callback
-	    Invoke changecmd $Loclist
-	}
+	mcpreferences {*}[mcutil getpreferences $newLocale]
     }
     return [lindex $Loclist 0]
 }
 
-# msgcat::GetPreferences --
+# msgcat::mcutil::getpreferences --
 #
 #	Get list of locales from a locale.
 #	The first element is always the lowercase locale.
 #	Other elements have one component separated by "_" less.
 #	Multiple "_" are seen as one separator: de__ch_spec de__ch de {}
 #
+#	This method is part of the ensemble mcutil
+#
 # Arguments:
 #	Locale.
 #
 # Results:
 #	Locale list
 
-proc msgcat::GetPreferences {locale} {
+proc msgcat::mcutil::getpreferences {locale} {
     set locale [string tolower $locale]
     set loclist [list $locale]
     while {-1 !=[set pos [string last "_" $locale]]} {
@@ -377,16 +378,51 @@ proc msgcat::GetPreferences {locale} {
 #	most preferred to least preferred.
 #
 # Arguments:
-#	None.
+#	New location list
 #
 # Results:
 #	Returns an ordered list of the locales preferred by the user.
 
-proc msgcat::mcpreferences {} {
+proc msgcat::mcpreferences {args} {
     variable Loclist
+
+    if {[llength $args] > 0} {
+	# args is the new loclist
+	if {![ListEqualString $args $Loclist]} {
+	    set Loclist $args
+
+	    # locale not loaded jet
+	    LoadAll $Loclist
+	    # Invoke callback
+	    Invoke changecmd $Loclist
+	}
+    }
     return $Loclist
 }
 
+# msgcat::ListStringEqual --
+#
+#	Compare two strings for equal string contents
+#
+# Arguments:
+#	list1		first list
+#	list2		second list
+#
+# Results:
+#	1 if lists of strings are identical, 0 otherwise
+
+proc msgcat::ListEqualString {list1 list2} {
+    if {[llength $list1] != [llength $list2]} {
+	return 0
+    }
+    foreach item1 $list1 item2 $list2 {
+	if {$item1 ne $item2} {
+	    return 0
+	}
+    }
+    return 1
+}
+
 # msgcat::mcloadedlocales --
 #
 #	Get or change the list of currently loaded default locales
@@ -470,7 +506,7 @@ proc msgcat::mcloadedlocales {subcommand} {
 # Results:
 #	Empty string, if not stated differently for the subcommand
 
-proc msgcat::mcpackagelocale {subcommand {locale ""}} {
+proc msgcat::mcpackagelocale {subcommand args} {
     # todo: implement using an ensemble
     variable Loclist
     variable LoadedLocales
@@ -478,27 +514,39 @@ proc msgcat::mcpackagelocale {subcommand {locale ""}} {
     variable PackageConfig
     # Check option
     # check if required item is exactly provided
-    if {[llength [info level 0]] == 2} {
-	# locale not given
-	unset locale
-    } else {
-	# locale given
-	if {$subcommand in
-		{"get" "isset" "unset" "preferences" "loaded" "clear"} } {
-	    return -code error "wrong # args: should be\
-		    \"[lrange [info level 0] 0 1]\""
-	}
-        set locale [string tolower $locale]
+    if {    [llength $args] > 0
+	    && $subcommand in {"get" "isset" "unset" "loaded" "clear"} } {
+	return -code error "wrong # args: should be\
+		\"[lrange [info level 0] 0 1]\""
     }
     set ns [PackageNamespaceGet]
 
     switch -exact -- $subcommand {
 	get { return [lindex [PackagePreferences $ns] 0] }
-	preferences { return [PackagePreferences $ns] }
 	loaded { return [PackageLocales $ns] }
-	present { return [expr {$locale in [PackageLocales $ns]} ]}
+	present {
+	    if {[llength $args] != 1} {
+		return -code error "wrong # args: should be\
+			\"[lrange [info level 0] 0 1] locale\""
+	    }
+	    return [expr {[string tolower [lindex $args 0]]
+		    in [PackageLocales $ns]} ]
+	}
 	isset { return [dict exists $PackageConfig loclist $ns] }
-	set { # set a package locale or add a package locale
+	set - preferences {
+	    # set a package locale or add a package locale
+	    set fSet [expr {$subcommand eq "set"}]
+	    
+	    # Check parameter
+	    if {$fSet && 1 < [llength $args] } {
+		return -code error "wrong # args: should be\
+			\"[lrange [info level 0] 0 1] ?locale?\""
+	    }
+
+	    # > Return preferences if no parameter
+	    if {!$fSet && 0 == [llength $args] } {
+		return [PackagePreferences $ns]
+	    }
 
 	    # Copy the default locale if no package locale set so far
 	    if {![dict exists $PackageConfig loclist $ns]} {
@@ -506,25 +554,43 @@ proc msgcat::mcpackagelocale {subcommand {locale ""}} {
 		dict set PackageConfig loadedlocales $ns $LoadedLocales
 	    }
 
-	    # Check if changed
-	    set loclist [dict get $PackageConfig loclist $ns]
-	    if {! [info exists locale] || $locale eq [lindex $loclist 0] } {
-		return [lindex $loclist 0]
+	    # No argument for set: return current package locale
+	    # The difference to no argument and subcommand "preferences" is,
+	    # that "preferences" does not set the package locale property.
+	    # This case is processed above, so no check for fSet here
+	    if { 0 == [llength $args] } {
+		return [lindex [dict get $PackageConfig loclist $ns] 0]
+	    }
+
+	    # Get new loclist
+	    if {$fSet} {
+		set loclist [mcutil getpreferences [lindex $args 0]]
+	    } else {
+		set loclist $args
+	    }
+
+	    # Check if not changed to return imediately
+	    if {    [ListEqualString $loclist\
+			[dict get $PackageConfig loclist $ns]] } {
+		if {$fSet} {
+		    return [lindex $loclist 0]
+		}
+		return $loclist
 	    }
 
 	    # Change loclist
-	    set loclist [GetPreferences $locale]
-	    set locale [lindex $loclist 0]
 	    dict set PackageConfig loclist $ns $loclist
 
 	    # load eventual missing locales
 	    set loadedLocales [dict get $PackageConfig loadedlocales $ns]
-	    if {$locale in $loadedLocales} { return $locale }
 	    set loadLocales [ListComplement $loadedLocales $loclist]
 	    dict set PackageConfig loadedlocales $ns\
 		    [concat $loadedLocales $loadLocales]
 	    Load $ns $loadLocales
-	    return $locale
+	    if {$fSet} {
+		return [lindex $loclist 0]
+	    }
+	    return $loclist
 	}
 	clear { # Remove all locales not contained in Loclist
 	    if {![dict exists $PackageConfig loclist $ns]} {
@@ -1116,7 +1182,7 @@ proc msgcat::mcmax {args} {
 
 # Convert the locale values stored in environment variables to a form
 # suitable for passing to [mclocale]
-proc msgcat::ConvertLocale {value} {
+proc msgcat::mcutil::ConvertLocale {value} {
     # Assume $value is of form: $language[_$territory][.$codeset][@modifier]
     # Convert to form: $language[_$territory][_$modifier]
     #
@@ -1176,7 +1242,7 @@ proc ::msgcat::PackageNamespaceGet {} {
 }
   
 # Initialize the default locale
-proc msgcat::Init {} {
+proc msgcat::mcutil::getsystemlocale {} {
     global env
 
     #
@@ -1184,10 +1250,8 @@ proc msgcat::Init {} {
     #
     foreach varName {LC_ALL LC_MESSAGES LANG} {
 	if {[info exists env($varName)] && ("" ne $env($varName))} {
-	    if {![catch {
-		mclocale [ConvertLocale $env($varName)]
-	    }]} {
-		return
+	    if {![catch { ConvertLocale $env($varName) } locale]} {
+		return $locale
 	    }
 	}
     }
@@ -1195,10 +1259,8 @@ proc msgcat::Init {} {
     # On Darwin, fallback to current CFLocale identifier if available.
     #
     if {[info exists ::tcl::mac::locale] && $::tcl::mac::locale ne ""} {
-	if {![catch {
-	    mclocale [ConvertLocale $::tcl::mac::locale]
-	}]} {
-	    return
+	if {![catch { ConvertLocale $::tcl::mac::locale] } locale]} {
+	    return $locale
 	}
     }
     #
@@ -1207,8 +1269,7 @@ proc msgcat::Init {} {
     #
     if {([info sharedlibextension] ne ".dll")
 	    || [catch {package require registry}]} {
-	mclocale C
-	return
+	return C
     }
     #
     # On Windows or Cygwin, try to set locale depending on registry
@@ -1239,8 +1300,8 @@ proc msgcat::Init {} {
 	    if {[dict exists $modifierDict $script]} {
 		append locale @ [dict get $modifierDict $script]
 	    }
-	    if {![catch {mclocale [ConvertLocale $locale]}]} {
-		return
+	    if {![catch {ConvertLocale $locale} locale]} {
+		return $locale
 	    }
 	}
     }
@@ -1249,8 +1310,7 @@ proc msgcat::Init {} {
     if {[catch {
 	set locale [registry get $key "locale"]
     }]} {
-	mclocale C
-	return
+	return C
     }
     #
     # Keep trying to match against smaller and smaller suffixes
@@ -1265,15 +1325,15 @@ proc msgcat::Init {} {
     set locale [string tolower $locale]
     while {[string length $locale]} {
 	if {![catch {
-	    mclocale [ConvertLocale [dict get $WinRegToISO639 $locale]]
-	}]} {
-	    return
+	    ConvertLocale [dict get $WinRegToISO639 $locale]
+	} localeOut]} {
+	    return $localeOut
 	}
 	set locale [string range $locale 1 end]
     }
     #
     # No translation known.  Fall back on "C" locale
     #
-    mclocale C
+    return C
 }
-msgcat::Init
+msgcat::mclocale [msgcat::mcutil getsystemlocale]
diff --git a/tests/msgcat.test b/tests/msgcat.test
index 7f872ed..7ab9bcf 100644
--- a/tests/msgcat.test
+++ b/tests/msgcat.test
@@ -194,6 +194,28 @@ namespace eval ::msgcat::test {
 	mclocale looks/ok/../../../../but/is/path/to/evil/code
     } -returnCodes error -match glob -result {invalid newLocale value *}
 
+    test msgcat-1.14 {mcpreferences, custom locale preferences} -setup {
+	variable locale [mclocale]
+	mclocale en
+	mcpreferences fr en {}
+    } -cleanup {
+	mclocale $locale
+    } -body {
+	mcpreferences
+    } -result {fr en {}}
+
+    test msgcat-1.15 {mcpreferences, overwrite custom locale preferences}\
+    -setup {
+	variable locale [mclocale]
+	mcpreferences fr en {}
+	mclocale en
+    } -cleanup {
+	mclocale $locale
+    } -body {
+	mcpreferences
+    } -result {en {}}
+
+
     # Tests msgcat-2.*: [mcset], [mcmset], namespace partitioning
 
     test msgcat-2.1 {mcset, global scope} {
@@ -833,13 +855,18 @@ namespace eval ::msgcat::test {
 	test msgcat-12.1 {mcpackagelocale no subcommand} -body {
 	    mcpackagelocale
 	} -returnCodes 1\
-	-result {wrong # args: should be "mcpackagelocale subcommand ?locale?"}
+	-result {wrong # args: should be "mcpackagelocale subcommand ?arg ...?"}
 
 	test msgcat-12.2 {mclpackagelocale wrong subcommand} -body {
 	    mcpackagelocale junk
 	} -returnCodes 1\
 	-result {unknown subcommand "junk": must be clear, get, isset, loaded, present, set, or unset}
 
+	test msgcat-12.2.1 {mclpackagelocale set multiple args} -body {
+	    mcpackagelocale set a b
+	} -returnCodes 1\
+	-result {wrong # args: should be "mcpackagelocale set ?locale?"}
+
 	test msgcat-12.3 {mcpackagelocale set} -setup {
 	    variable locale [mclocale]
 	} -cleanup {
@@ -944,6 +971,30 @@ namespace eval ::msgcat::test {
 	    list [mcpackagelocale present foo] [mcpackagelocale present bar]
 	} -result {0 1}
 
+	test msgcat-12.11 {mcpackagelocale custom preferences} -setup {
+	    variable locale [mclocale]
+	} -cleanup {
+	    mclocale $locale
+	    mcforgetpackage
+	} -body {
+	    mclocale foo
+	    set res [list [mcpackagelocale preferences]]
+	    mcpackagelocale preferences bar {}
+	    lappend res [mcpackagelocale preferences]
+	} -result {{foo {}} {bar {}}}
+
+	test msgcat-12.12 {mcpackagelocale preferences -> no isset} -setup {
+	    variable locale [mclocale]
+	} -cleanup {
+	    mclocale $locale
+	    mcforgetpackage
+	} -body {
+	    mclocale foo
+	    mcpackagelocale preferences
+	    mcpackagelocale isset
+	} -result {0}
+
+	
     # Tests msgcat-13.*: [mcpackageconfig subcmds]
 
 	test msgcat-13.1 {mcpackageconfig no subcommand} -body {
@@ -1261,6 +1312,46 @@ namespace eval ::msgcat::test {
 
     interp bgerror {} $bgerrorsaved
 
+    # Tests msgcat-15.*: [mcutil]
+
+    test msgcat-15.1 {mcutil - no argument} -body {
+	mcutil
+    } -returnCodes 1\
+    -result {wrong # args: should be "mcutil subcommand ?arg ...?"}
+
+    test msgcat-15.2 {mcutil - wrong argument} -body {
+	mcutil junk
+    } -returnCodes 1\
+    -result {unknown subcommand "junk": must be getpreferences, or getsystemlocale}
+    
+    test msgcat-15.3 {mcutil - partial argument} -body {
+	mcutil getsystem
+    } -returnCodes 1\
+    -result {unknown subcommand "getsystem": must be getpreferences, or getsystemlocale}
+    
+    test msgcat-15.4 {mcutil getpreferences - no argument} -body {
+	mcutil getpreferences
+    } -returnCodes 1\
+    -result {wrong # args: should be "mcutil getpreferences locale"}
+    
+    test msgcat-15.5 {mcutil getpreferences - DE_de} -body {
+	mcutil getpreferences DE_de
+    } -result {de_de de {}}
+    
+    test msgcat-15.6 {mcutil getsystemlocale - wrong argument} -body {
+	mcutil getsystemlocale DE_de
+    } -returnCodes 1\
+    -result {wrong # args: should be "mcutil getsystemlocale"}
+    
+    # The result is system dependent
+    # So just test if it runs
+    # The environment variable version was test with test 0.x
+    test msgcat-15.7 {mcutil getsystemlocale} -body {
+	mcutil getsystemlocale
+	set ok ok
+    } -result {ok}
+    
+    
     cleanupTests
 }
 namespace delete ::msgcat::test