Tcl Source Code

testConstraint testsetplatform [llength [info commands testsetplatform]]
testConstraint testchmod [llength [info commands testchmod]]
testConstraint winLessThan10 0
# Don't know how to determine this constraint correctly
testConstraint notNetworkFilesystem 0
testConstraint reg 0
if {[testConstraint win]} {
    if {[catch {
	# Is the registry extension already static to this shell?
	try {
	    load {} Registry
	    set ::reglib {}
	} on error {} {
	    # try the location given to use on the commandline to tcltest
	    ::tcltest::loadTestedCommands
	    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
testConstraint notWsl [expr {[llength [array names ::env *WSL*]] == 0}]

set tmpspace /tmp;# default value
# Find a group that exists on this Unix system, or else skip tests that

	    regexp {^[^(]*\(([^)]*)\)} [exec id] -> user
	}
    }
    if {$user eq ""} {
	set user "root"
    }
}

# 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
    close $f
    return $string
}

    file home
} -result relative/path
test fCmd-31.6 {file home USER} -body {
    # Note - as in 8.x this form does NOT necessarily give same result as
    # 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 [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 ~
} -result [file join $::env(HOME)]
test fCmd-32.2 {file tildeexpand ~ - obeys env} -setup {
    set ::env(HOME) $::env(HOME)/xxx
} -cleanup {

    file tildeexpand ~
} -result relative/path
test fCmd-32.5 {file tildeexpand ~USER} -body {
    # Note - as in 8.x this form does NOT necessarily give same result as
    # 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 [gethomedirglob $::tcl_platform(user)]
test fCmd-32.6 {file tildeexpand ~UNKNOWNUSER} -body {
    file tildeexpand ~nosuchuser
} -returnCodes error -result {user "nosuchuser" doesn't exist}
test fCmd-32.7 {file tildeexpand ~extra arg} -body {
    file tildeexpand ~ arg
} -returnCodes error -result {wrong # args: should be "file tildeexpand path"}
test fCmd-32.8 {file tildeexpand ~/path} -body {
    file tildeexpand ~/foo
} -result [file join $::env(HOME)/foo]
test fCmd-32.9 {file tildeexpand ~USER/bar} -body {
    # Note - as in 8.x this form does NOT necessarily give same result as
    # 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 [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}
test fCmd-32.11 {file tildeexpand /~/path} -body {
    file tildeexpand /~/foo
} -result /~/foo
test fCmd-32.12 {file tildeexpand /~user/path} -body {

    file tildeexpand ~\\foo
} -constraints win -result [file join $::env(HOME)/foo]
test fCmd-32.16 {file tildeexpand ~USER\\bar} -body {
    # Note - as in 8.x this form does NOT necessarily give same result as
    # 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 [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
cleanup
if {[testConstraint unix]} {
    removeDirectory tcl[pid] /tmp
}

} -returnCodes error -result {user "noonewiththisname" doesn't exist}
test filesystem-1.30.1 {normalisation of existing user} -body {
    catch {file normalize ~$::tcl_platform(user)}
} -result {0}
test filesystem-1.30.2 {normalisation of nonexistent user specified as user@domain} -body {
    file normalize ~nonexistentuser@nonexistentdomain
} -returnCodes error -result {user "nonexistentuser@nonexistentdomain" doesn't exist}
test filesystem-1.30.3 {file normalization should distinguish between ~ and ~user} -setup {
    set oldhome $::env(HOME)
    set olduserhome [file normalize ~$::tcl_platform(user)]
    set ::env(HOME) [file join $oldhome temp]
} -cleanup {
    set env(HOME) $oldhome
} -body {
    list [string equal [file normalize ~] $::env(HOME)] \
        [string equal $olduserhome [file normalize ~$::tcl_platform(user)]]
} -result {1 1}
test filesystem-1.31 {link normalisation: link near filesystem root} {testsetplatform} {
    testsetplatform unix
    file normalize /foo/../bar
} {/bar}
test filesystem-1.32 {link normalisation: link near filesystem root} {testsetplatform} {
    testsetplatform unix
    file normalize /../bar

    Tcl_DStringInit(bufferPtr);

    wDomain = NULL;
    domain = Tcl_UtfFindFirst(name, '@');
    if (domain == NULL) {
	const char *ptr;

        /*
         * Treat the current user as a special case because the general case
         * below does not properly retrieve the path. The NetUserGetInfo
         * call returns an empty path and the code defaults to the user's
         * name in the profiles directory. On modern Windows systems, this
         * is generally wrong as when the account is a Microsoft account,
         * for example [email protected], the directory name is
         * abcde and not abcdefghi.
         *
         * Note we could have just used env(USERPROFILE) here but
         * the intent is to retrieve (as on Unix) the system's view
         * of the home irrespective of environment settings of HOME
         * and USERPROFILE.
         *
         * Fixing this for the general user needs more investigating but
         * at least for the current user we can use a direct call.
         */
	ptr = TclpGetUserName(&ds);
	if (ptr != NULL && strcasecmp(name, ptr) == 0) {

            HANDLE hProcess;
            WCHAR buf[MAX_PATH];
            DWORD nChars = sizeof(buf) / sizeof(buf[0]);
            /* Sadly GetCurrentProcessToken not in Win 7 so slightly longer */

            hProcess = GetCurrentProcess(); /* Need not be closed */

            if (hProcess) {
                HANDLE hToken;
                if (OpenProcessToken(hProcess, TOKEN_QUERY, &hToken)) {
                    if (GetUserProfileDirectoryW(hToken, buf, &nChars)) {
                        Tcl_WinTCharToUtf((TCHAR *)buf,
                                          (nChars-1)*sizeof(WCHAR),
                                          bufferPtr);

                        result = Tcl_DStringValue(bufferPtr);
                        rc = 1;
                    }
                    CloseHandle(hToken);
                }
            }
	}
	Tcl_DStringFree(&ds);
    } else {
	Tcl_DStringInit(&ds);
	wName = Tcl_UtfToWCharDString(domain + 1, TCL_INDEX_NONE, &ds);
	rc = NetGetDCName(NULL, wName, (LPBYTE *) &wDomain);
	Tcl_DStringFree(&ds);

	    }
	    NetApiBufferFree((void *) uiPtr);
	}
	Tcl_DStringFree(&ds);
    }
    if (wDomain != NULL) {
	NetApiBufferFree((void *) wDomain);
























    }

    return result;
}

/*
 *---------------------------------------------------------------------------