TIP 499: Custom locale search for msgcat

6 files changed, 154 insertions, 42 deletions

diff --git a/changes b/changes
index f89704b..120f9ff 100644..100755
--- a/changes
+++ b/changes
@@ -8879,3 +8879,6 @@ 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
+
+2018-02-07 (TIP 499) custom locale preference list (nijtmans)
+=> msgcat 1.7.0
diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl
index 646bc17..0f8f9b3 100644..100755
--- a/library/msgcat/msgcat.tcl
+++ b/library/msgcat/msgcat.tcl
@@ -14,11 +14,11 @@
 package require Tcl 8.5-
 # 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\
-            mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\
+    namespace export mc mcexists mcload mclocale mcmax mcmset mcpreferences\
+	    mcset mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\
 	    mcpackageconfig mcpackagelocale
 
     # Records the list of locales to search
@@ -303,14 +303,7 @@ 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 {*}[GetPreferences $newLocale]
     }
     return [lindex $Loclist 0]
 }
@@ -349,16 +342,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
@@ -442,7 +470,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
@@ -450,27 +478,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 [uplevel 1 {::namespace current}]
 
     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]} {
@@ -478,25 +518,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 [GetPreferences [string tolower [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]} {
diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl
index 72c5dc0..fe3b3a1 100644..100755
--- a/library/msgcat/pkgIndex.tcl
+++ b/library/msgcat/pkgIndex.tcl
@@ -1,2 +1,2 @@
 if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
-package ifneeded msgcat 1.6.1 [list source [file join $dir msgcat.tcl]]
+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..b0d2bd3 100644..100755
--- 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} {
@@ -811,13 +833,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 {
@@ -922,6 +949,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 {
diff --git a/unix/Makefile.in b/unix/Makefile.in
index 244ad29..4487ff5 100644..100755
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -850,8 +850,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.5/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 5be7492..e5e2384 100644..100755
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -659,8 +659,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.5/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";