Merge 8.7: Bug [9c5a00c69d]. Fix ~user on Windows

2 files changed, 71 insertions, 5 deletions

diff --git a/tests/fCmd.test b/tests/fCmd.test
index d656b3d..0752be6 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -27,7 +27,7 @@ testConstraint winLessThan10 0
 testConstraint notNetworkFilesystem 0
 testConstraint reg 0
 if {[testConstraint win]} {
-    catch {
+    if {[catch {
 	# Is the registry extension already static to this shell?
 	try {
 	    load {} Registry
@@ -38,8 +38,11 @@ if {[testConstraint win]} {
 	    load $::reglib Registry
 	}
 	testConstraint reg 1
+    } regError]} {
+        catch {package require registry; testConstraint reg 1}
     }
 }
+
 testConstraint notInCIenv [expr {![info exists ::env(CI)] || !$::env(CI)}]
 
 # File permissions broken on wsl without some "exotic" wsl configuration
@@ -108,6 +111,45 @@ if {[testConstraint win]} {
     }
 }
 
+# Try getting a lower case glob pattern that will match the home directory of
+# a given user to test ~user and [file tildeexpand ~user]. Note this may not
+# be the same as ~ even when "user" is current user. For example, on Unix
+# platforms ~ will return HOME envvar, but ~user will lookup password file
+# bypassing HOME. If home directory not found, returns *$user* so caller can
+# succeed by using glob matching under the hope that the path contains
+# the user name.
+proc gethomedirglob {user} {
+    if {[testConstraint unix]} {
+        if {![catch {
+            exec {*}[auto_execok sh] -c "echo ~$user"
+        } home]} {
+            set home [string trim $home]
+            if {$home ne ""} {
+                # Expect exact match (except case), no glob * added
+                return [string tolower $home]
+            }
+        }
+    } elseif {[testConstraint reg]} {
+        # Windows with registry extension loaded
+        if {![catch {
+            set sid [exec {*}[auto_execok powershell] -Command "(Get-LocalUser -Name '$user')\[0\].sid.Value"]
+            set sid [string trim $sid]
+            # Get path from the Windows registry
+            set home [registry get "HKEY_LOCAL_MACHINE\\Software\\Microsoft\\Windows NT\\CurrentVersion\\ProfileList\\$sid" ProfileImagePath]
+            set home [string trim $home]
+        } result]} {
+            if {$home ne ""} {
+                # file join for \ -> /
+                return [file join [string tolower $home]]
+            }
+        }
+    }
+
+    # Caller will need to use glob matching and hope user
+    # name is in the home directory path
+    return *$user*
+}
+
 proc createfile {file {string a}} {
     set f [open $file w]
     puts -nonewline $f $string
@@ -2701,13 +2743,20 @@ test fCmd-31.6 {file home USER} -body {
     # env(HOME) even when user is current user. Assume result contains user
     # name, else not sure how to check
     string tolower [file home $::tcl_platform(user)]
-} -match glob -result [string tolower "*$::tcl_platform(user)*"]
+} -match glob -result [gethomedirglob $::tcl_platform(user)]
 test fCmd-31.7 {file home UNKNOWNUSER} -body {
     file home nosuchuser
 } -returnCodes error -result {user "nosuchuser" doesn't exist}
 test fCmd-31.8 {file home extra arg} -body {
     file home $::tcl_platform(user) arg
 } -returnCodes error -result {wrong # args: should be "file home ?user?"}
+test fCmd-31.9 {file home USER does not follow env(HOME)} -setup {
+    set ::env(HOME) [file join $::env(HOME) foo]
+} -cleanup {
+    set ::env(HOME) [file dirname $::env(HOME)]
+} -body {
+    string tolower [file home $::tcl_platform(user)]
+} -match glob -result [gethomedirglob $::tcl_platform(user)]
 
 test fCmd-32.1 {file tildeexpand ~} -body {
     file tildeexpand ~
@@ -2743,7 +2792,7 @@ test fCmd-32.5 {file tildeexpand ~USER} -body {
     # env(HOME) even when user is current user. Assume result contains user
     # name, else not sure how to check
     string tolower [file tildeexpand ~$::tcl_platform(user)]
-} -match glob -result [string tolower "*$::tcl_platform(user)*"]
+} -match glob -result [gethomedirglob $::tcl_platform(user)]
 test fCmd-32.6 {file tildeexpand ~UNKNOWNUSER} -body {
     file tildeexpand ~nosuchuser
 } -returnCodes error -result {user "nosuchuser" doesn't exist}
@@ -2758,7 +2807,7 @@ test fCmd-32.9 {file tildeexpand ~USER/bar} -body {
     # env(HOME) even when user is current user. Assume result contains user
     # name, else not sure how to check
     string tolower [file tildeexpand ~$::tcl_platform(user)/bar]
-} -match glob -result [string tolower "*$::tcl_platform(user)*/bar"]
+} -match glob -result [file join [gethomedirglob $::tcl_platform(user)] bar]
 test fCmd-32.10 {file tildeexpand ~UNKNOWNUSER} -body {
     file tildeexpand ~nosuchuser/foo
 } -returnCodes error -result {user "nosuchuser" doesn't exist}
@@ -2782,7 +2831,14 @@ test fCmd-32.16 {file tildeexpand ~USER\\bar} -body {
     # env(HOME) even when user is current user. Assume result contains user
     # name, else not sure how to check
     string tolower [file tildeexpand ~$::tcl_platform(user)\\bar]
-} -constraints win -match glob -result [string tolower "*$::tcl_platform(user)*/bar"]
+} -constraints win -match glob -result [file join [gethomedirglob $::tcl_platform(user)] bar]
+test fCmd-32.17 {file tildeexpand ~USER does not mirror HOME} -setup {
+    set ::env(HOME) [file join $::env(HOME) foo]
+} -cleanup {
+    set ::env(HOME) [file dirname $::env(HOME)]
+} -body {
+    string tolower [file tildeexpand ~$::tcl_platform(user)]
+} -match glob -result [gethomedirglob $::tcl_platform(user)]
 
 
 # cleanup
diff --git a/tests/fileSystem.test b/tests/fileSystem.test
index 5e98c39..d104282 100644
--- a/tests/fileSystem.test
+++ b/tests/fileSystem.test
@@ -275,6 +275,16 @@ test filesystem-1.30 {
 test filesystem-1.30.1 {normalisation of existing user} -body {
     file normalize ~$::tcl_platform(user)
 } -result [file join [pwd] ~$::tcl_platform(user)]
+test filesystem-1.30.3 {file normalization should distinguish between ~ and ~user} -setup {
+    set oldhome $::env(HOME)
+    set olduserhome [file home $::tcl_platform(user)]
+    set ::env(HOME) [file join $oldhome temp]
+} -cleanup {
+    set env(HOME) $oldhome
+} -body {
+    list [string equal [file home] $::env(HOME)] \
+        [string equal $olduserhome [file home $::tcl_platform(user)]]
+} -result {1 1}
 test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} {
     testsetplatform unix
     file normalize /foo/../bar