-- cgit v0.12 From 90b60f208406b3811bad8f7327b663239fd1eea7 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Sat, 6 Aug 2022 03:12:49 +0000 Subject: Added file home command for (possible) Tcl 9 TIP 602 migration --- generic/tclCmdAH.c | 1 + generic/tclFCmd.c | 38 ++++++++ generic/tclInt.h | 7 ++ generic/tclPathObj.c | 239 +++++++++++++++++++++++++++++++++++++++++++++++++++ tests/cmdAH.test | 4 +- tests/fCmd.test | 51 +++++++++++ 6 files changed, 338 insertions(+), 2 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 28fc210..62c799a 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -1191,6 +1191,7 @@ TclInitFileCmd( {"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"home", TclFileHomeCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"join", PathJoinCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 6eb6644..747d8a6 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -1650,6 +1650,44 @@ TclFileTempDirCmd( } /* + *---------------------------------------------------------------------- + * + * TclFileHomeCmd -- + * + * This function is invoked to process the "file home" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclFileHomeCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *homeDirObj; + + if (objc != 1 && objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?user?"); + return TCL_ERROR; + } + homeDirObj = TclGetHomeDirObj(interp, objc == 1 ? NULL : Tcl_GetString(objv[1])); + if (homeDirObj == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, homeDirObj); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclInt.h b/generic/tclInt.h index ac6fb54..782eadb 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2976,6 +2976,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclFileReadLinkCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileTempDirCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileHomeCmd; MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc, ClientData clientData); MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc, @@ -3083,6 +3084,12 @@ MODULE_SCOPE int TclIsDigitProc(int byte); MODULE_SCOPE int TclIsBareword(int byte); MODULE_SCOPE Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[], int forceRelative); +MODULE_SCOPE int TclGetHomeDir(Tcl_Interp *interp, const char *user, + Tcl_DString *dsPtr); +MODULE_SCOPE Tcl_Obj * TclGetHomeDirObj(Tcl_Interp *interp, const char *user); +MODULE_SCOPE Tcl_Obj * TclResolveTildePath(Tcl_Interp *interp, + Tcl_Obj *pathObj); +MODULE_SCOPE Tcl_Obj * TclResolveTildePathList(Tcl_Obj *pathsObj); MODULE_SCOPE int TclJoinThread(Tcl_ThreadId id, int *result); MODULE_SCOPE void TclLimitRemoveAllHandlers(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 9524f26..bb269de 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -2559,6 +2559,245 @@ TclNativePathInFilesystem( } /* + *---------------------------------------------------------------------- + * + * TclGetHomeDir -- + * + * Returns the home directory of a user. Note there is a difference + * between not specifying a user and explicitly specifying the current + * user. This mimics Tcl8's tilde expansion. + * + * Results: + * Returns TCL_OK on success with home directory path in *dsPtr + * and TCL_ERROR on failure with error message in interp if non-NULL. + * + *---------------------------------------------------------------------- + */ +int +TclGetHomeDir( + Tcl_Interp *interp, /* May be NULL. Only used for error messages */ + const char *user, /* User name. NULL -> current user */ + Tcl_DString *dsPtr) /* Output. Is initialized by the function. Must be + freed on success */ +{ + const char *dir; + Tcl_DString nativeString; + + Tcl_DStringInit(dsPtr); + Tcl_DStringInit(&nativeString); + + if (user == NULL || user[0] == 0) { + /* No user name specified -> current user */ + + dir = TclGetEnv("HOME", &nativeString); + if (dir == NULL) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't find HOME environment variable to" + " expand path", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", + "HOMELESS", NULL); + } + return TCL_ERROR; + } + } else { + /* User name specified - ~user */ + dir = TclpGetUserHome(user, &nativeString); + if (dir == NULL) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "user \"%s\" doesn't exist", user)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER", + NULL); + } + return TCL_ERROR; + } + } + Tcl_JoinPath(1, &dir, dsPtr); + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetHomeDirObj -- + * + * Wrapper around TclGetHomeDir. See that function. + * + * Results: + * Returns a Tcl_Obj containing the home directory of a user + * or NULL on failure with error message in interp if non-NULL. + * + *---------------------------------------------------------------------- + */ +Tcl_Obj * +TclGetHomeDirObj( + Tcl_Interp *interp, /* May be NULL. Only used for error messages */ + const char *user) /* User name. NULL -> current user */ +{ + Tcl_DString dirString; + + if (TclGetHomeDir(interp, user, &dirString) != TCL_OK) { + return NULL; + } + return TclDStringToObj(&dirString); +} + +/* + *---------------------------------------------------------------------- + * + * TclResolveTildePath -- + * + * If the passed path is begins with a tilde, does tilde resolution + * and returns a Tcl_Obj containing the resolved path. If the tilde + * component cannot be resolved, returns NULL. If the path does not + * begin with a tilde, returns as is. + * + * The trailing components of the path are returned verbatim. No + * processing is done on them. Moreover, no assumptions should be + * made about the separators in the returned path. They may be / + * or native. Appropriate path manipulations functions should be + * used by caller if desired. + * + * Results: + * Returns a Tcl_Obj with resolved path. This may be a new Tcl_Obj + * with ref count 0 or that pathObj that was passed in without its + * ref count modified. + * Returns NULL if the path begins with a ~ that cannot be resolved + * and stores an error message in interp if non-NULL. + * + *---------------------------------------------------------------------- + */ +Tcl_Obj * +TclResolveTildePath( + Tcl_Interp *interp, /* May be NULL. Only used for error messages */ + Tcl_Obj *pathObj) +{ + const char *path; + int len; + Tcl_Obj *resolvedObj; + Tcl_DString dirString; + int split; + + path = Tcl_GetStringFromObj(pathObj, &len); + if (path[0] != '~') { + return pathObj; + } + + /* + * We have multiple cases '~/foo/bar...', '~user/foo/bar...', etc. + * split becomes value 1 for '~/...' as well as for '~'. Note on + * Windows FindSplitPos will implicitly check for '\' as separator + * in addition to what is passed. + */ + split = FindSplitPos(path, '/'); + + if (split == 1) { + /* No user name specified -> current user */ + if (TclGetHomeDir(interp, NULL, &dirString) != TCL_OK) { + return NULL; + } + } else { + /* User name specified - ~user */ + + const char *expandedUser; + Tcl_DString userName; + + Tcl_DStringInit(&userName); + Tcl_DStringAppend(&userName, path+1, split-1); + expandedUser = Tcl_DStringValue(&userName); + + if (TclGetHomeDir(interp, expandedUser, &dirString) != TCL_OK) { + Tcl_DStringFree(&userName); + return NULL; + } + Tcl_DStringFree(&userName); + } + resolvedObj = TclDStringToObj(&dirString); + + if (split < len) { + /* If any trailer, append it verbatim */ + Tcl_AppendToObj(resolvedObj, split + path, len-split); + } + + return resolvedObj; +} + +/* + *---------------------------------------------------------------------- + * + * TclResolveTildePathList -- + * + * Given a Tcl_Obj that is a list of paths, returns a Tcl_Obj containing + * the paths with any ~-prefixed paths resolved. + * + * Empty strings and ~-prefixed paths that cannot be resolved are + * removed from the returned list. + * + * The trailing components of the path are returned verbatim. No + * processing is done on them. Moreover, no assumptions should be + * made about the separators in the returned path. They may be / + * or native. Appropriate path manipulations functions should be + * used by caller if desired. + * + * Results: + * Returns a Tcl_Obj with resolved paths. This may be a new Tcl_Obj with + * reference count 0 or the original passed-in Tcl_Obj if no paths needed + * resolution. A NULL is returned if the passed in value is not a list + * or was NULL. + * + *---------------------------------------------------------------------- + */ +Tcl_Obj * +TclResolveTildePathList( + Tcl_Obj *pathsObj) +{ + Tcl_Obj **objv; + int objc; + int i; + Tcl_Obj *resolvedPaths; + const char *path; + + if (pathsObj == NULL) { + return NULL; + } + if (Tcl_ListObjGetElements(NULL, pathsObj, &objc, &objv) != TCL_OK) { + return NULL; /* Not a list */ + } + + /* + * Figure out if any paths need resolving to avoid unnecessary allocations. + */ + for (i = 0; i < objc; ++i) { + path = Tcl_GetString(objv[i]); + if (path[0] == '~') { + break; /* At least one path needs resolution */ + } + } + if (i == objc) { + return pathsObj; /* No paths needed to be resolved */ + } + + resolvedPaths = Tcl_NewListObj(objc, NULL); + for (i = 0; i < objc; ++i) { + Tcl_Obj *resolvedPath; + path = Tcl_GetString(objv[i]); + if (path[0] == 0) { + continue; /* Skip empty strings */ + } + resolvedPath = TclResolveTildePath(NULL, objv[i]); + if (resolvedPath) { + /* Paths that cannot be resolved are skipped */ + Tcl_ListObjAppendElement(NULL, resolvedPaths, resolvedPath); + } + } + + return resolvedPaths; +} + + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/tests/cmdAH.test b/tests/cmdAH.test index ab1a8e6..3aa9f71 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -355,7 +355,7 @@ test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { } -result {wrong # args: should be "file subcommand ?arg ...?"} test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body { file x -} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, home, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body { file exists } -result {wrong # args: should be "file exists name"} @@ -1686,7 +1686,7 @@ test cmdAH-29.6.1 { # Error conditions test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file gorp x -} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, home, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file ex x } -match glob -result {unknown or ambiguous subcommand "ex": must be *} diff --git a/tests/fCmd.test b/tests/fCmd.test index 13f3720..72a3cd5 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -2556,6 +2556,57 @@ test fCmd-30.3 {file readable on 'pagefile.sys'} -constraints {win notInCIenv} - } return $r } -result {exists 1 readable 0 stat 0 {}} + +test fCmd-31.1 {file home} -body { + file home +} -result [file join $::env(HOME)] +test fCmd-31.2 {file home - obeys env} -setup { + set ::env(HOME) $::env(HOME)/xxx +} -cleanup { + set ::env(HOME) [file dirname $::env(HOME)] +} -body { + file home +} -result [file join $::env(HOME) xxx] +test fCmd-31.3 {file home - \ -> /} -constraints win -setup { + set saved $::env(HOME) + set ::env(HOME) C:\\backslash\\path +} -cleanup { + set ::env(HOME) $saved +} -body { + file home +} -result C:/backslash/path +test fCmd-31.4 {file home - error} -setup { + set saved $::env(HOME) + unset ::env(HOME) +} -cleanup { + set ::env(HOME) $saved +} -body { + file home +} -returnCodes error -result {couldn't find HOME environment variable to expand path} +test fCmd-31.5 { + file home - relative path. Following 8.x ~ expansion behavior, relative + paths are not made absolute +} -setup { + set saved $::env(HOME) + set ::env(HOME) relative/path +} -cleanup { + set ::env(HOME) $saved +} -body { + 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 + file home $::tcl_platform(user) +} -match glob -result "*$::tcl_platform(user)*" +test fCmd-31.6 {file home UNKNOWNUSER} -body { + file home nosuchuser +} -returnCodes error -result {user "nosuchuser" doesn't exist} +test fCmd-31.7 {file home extra arg} -body { + file home $::tcl_platform(user) arg +} -returnCodes error -result {wrong # args: should be "file home ?user?"} + # cleanup cleanup -- cgit v0.12 From 74f8d5493bfe3936ae043a8bea5478decf86a33b Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 30 Aug 2022 09:40:35 +0000 Subject: Backport TIP 602 tildeexpand --- generic/tclCmdAH.c | 3 +- generic/tclFCmd.c | 38 +++++++++++++++++++++++++ generic/tclInt.h | 5 ++-- generic/tclPathObj.c | 80 +++++++++++++++++++++++++++++----------------------- tests/cmdAH.test | 4 +-- tests/fCmd.test | 79 +++++++++++++++++++++++++++++++++++++++++++++++++-- 6 files changed, 166 insertions(+), 43 deletions(-) diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 62c799a..06919a2 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -1191,7 +1191,7 @@ TclInitFileCmd( {"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, - {"home", TclFileHomeCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"home", TclFileHomeCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, {"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"join", PathJoinCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, @@ -1215,6 +1215,7 @@ TclInitFileCmd( {"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"tempdir", TclFileTempDirCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, {"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 1}, + {"tildeexpand", TclFileTildeExpandCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, {"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 747d8a6..2d24207 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -1688,6 +1688,44 @@ TclFileHomeCmd( } /* + *---------------------------------------------------------------------- + * + * TclFileTildeExpandCmd -- + * + * This function is invoked to process the "file tildeexpand" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclFileTildeExpandCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *expandedPathObj; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "path"); + return TCL_ERROR; + } + expandedPathObj = TclResolveTildePath(interp, objv[1]); + if (expandedPathObj == NULL) { + return TCL_ERROR; + } + Tcl_SetObjResult(interp, expandedPathObj); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclInt.h b/generic/tclInt.h index 9fec5b0..80e60a3 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3141,6 +3141,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileTempDirCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileHomeCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileTildeExpandCmd; MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc, ClientData clientData); MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc, @@ -3248,8 +3249,8 @@ MODULE_SCOPE int TclIsDigitProc(int byte); MODULE_SCOPE int TclIsBareword(int byte); MODULE_SCOPE Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[], int forceRelative); -MODULE_SCOPE int TclGetHomeDir(Tcl_Interp *interp, const char *user, - Tcl_DString *dsPtr); +MODULE_SCOPE int MakeTildeRelativePath(Tcl_Interp *interp, const char *user, + const char *subPath, Tcl_DString *dsPtr); MODULE_SCOPE Tcl_Obj * TclGetHomeDirObj(Tcl_Interp *interp, const char *user); MODULE_SCOPE Tcl_Obj * TclResolveTildePath(Tcl_Interp *interp, Tcl_Obj *pathObj); diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index bb269de..250ad6a 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -2561,11 +2561,17 @@ TclNativePathInFilesystem( /* *---------------------------------------------------------------------- * - * TclGetHomeDir -- + * MakeTildeRelativePath -- * - * Returns the home directory of a user. Note there is a difference - * between not specifying a user and explicitly specifying the current - * user. This mimics Tcl8's tilde expansion. + * Returns a path relative to the home directory of a user. + * Note there is a difference between not specifying a user and + * explicitly specifying the current user. This mimics Tcl8's tilde + * expansion. + * + * The subPath argument is joined to the expanded home directory + * as in Tcl_JoinPath. This means if it is not relative, it will + * returned as the result with the home directory only checked + * for user name validity. * * Results: * Returns TCL_OK on success with home directory path in *dsPtr @@ -2574,22 +2580,23 @@ TclNativePathInFilesystem( *---------------------------------------------------------------------- */ int -TclGetHomeDir( - Tcl_Interp *interp, /* May be NULL. Only used for error messages */ - const char *user, /* User name. NULL -> current user */ - Tcl_DString *dsPtr) /* Output. Is initialized by the function. Must be +MakeTildeRelativePath( + Tcl_Interp *interp, /* May be NULL. Only used for error messages */ + const char *user, /* User name. NULL -> current user */ + const char *subPath, /* Rest of path. May be NULL */ + Tcl_DString *dsPtr) /* Output. Is initialized by the function. Must be freed on success */ { const char *dir; - Tcl_DString nativeString; + Tcl_DString dirString; Tcl_DStringInit(dsPtr); - Tcl_DStringInit(&nativeString); + Tcl_DStringInit(&dirString); if (user == NULL || user[0] == 0) { /* No user name specified -> current user */ - dir = TclGetEnv("HOME", &nativeString); + dir = TclGetEnv("HOME", &dirString); if (dir == NULL) { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -2602,7 +2609,7 @@ TclGetHomeDir( } } else { /* User name specified - ~user */ - dir = TclpGetUserHome(user, &nativeString); + dir = TclpGetUserHome(user, &dirString); if (dir == NULL) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2613,7 +2620,16 @@ TclGetHomeDir( return TCL_ERROR; } } - Tcl_JoinPath(1, &dir, dsPtr); + if (subPath) { + const char *parts[2]; + parts[0] = dir; + parts[1] = subPath; + Tcl_JoinPath(2, parts, dsPtr); + } else { + Tcl_JoinPath(1, &dir, dsPtr); + } + + Tcl_DStringFree(&dirString); return TCL_OK; } @@ -2623,7 +2639,7 @@ TclGetHomeDir( * * TclGetHomeDirObj -- * - * Wrapper around TclGetHomeDir. See that function. + * Wrapper around MakeTildeRelativePath. See that function. * * Results: * Returns a Tcl_Obj containing the home directory of a user @@ -2638,7 +2654,7 @@ TclGetHomeDirObj( { Tcl_DString dirString; - if (TclGetHomeDir(interp, user, &dirString) != TCL_OK) { + if (MakeTildeRelativePath(interp, user, NULL, &dirString) != TCL_OK) { return NULL; } return TclDStringToObj(&dirString); @@ -2654,12 +2670,6 @@ TclGetHomeDirObj( * component cannot be resolved, returns NULL. If the path does not * begin with a tilde, returns as is. * - * The trailing components of the path are returned verbatim. No - * processing is done on them. Moreover, no assumptions should be - * made about the separators in the returned path. They may be / - * or native. Appropriate path manipulations functions should be - * used by caller if desired. - * * Results: * Returns a Tcl_Obj with resolved path. This may be a new Tcl_Obj * with ref count 0 or that pathObj that was passed in without its @@ -2676,9 +2686,8 @@ TclResolveTildePath( { const char *path; int len; - Tcl_Obj *resolvedObj; - Tcl_DString dirString; int split; + Tcl_DString resolvedPath; path = Tcl_GetStringFromObj(pathObj, &len); if (path[0] != '~') { @@ -2695,12 +2704,13 @@ TclResolveTildePath( if (split == 1) { /* No user name specified -> current user */ - if (TclGetHomeDir(interp, NULL, &dirString) != TCL_OK) { + if (MakeTildeRelativePath( + interp, NULL, path[1] ? 2 + path : NULL, &resolvedPath) + != TCL_OK) { return NULL; } } else { /* User name specified - ~user */ - const char *expandedUser; Tcl_DString userName; @@ -2708,20 +2718,18 @@ TclResolveTildePath( Tcl_DStringAppend(&userName, path+1, split-1); expandedUser = Tcl_DStringValue(&userName); - if (TclGetHomeDir(interp, expandedUser, &dirString) != TCL_OK) { - Tcl_DStringFree(&userName); + /* path[split] is / or \0 */ + if (MakeTildeRelativePath(interp, + expandedUser, + path[split] ? &path[split+1] : NULL, + &resolvedPath) + != TCL_OK) { + Tcl_DStringFree(&userName); return NULL; } - Tcl_DStringFree(&userName); - } - resolvedObj = TclDStringToObj(&dirString); - - if (split < len) { - /* If any trailer, append it verbatim */ - Tcl_AppendToObj(resolvedObj, split + path, len-split); + Tcl_DStringFree(&userName); } - - return resolvedObj; + return TclDStringToObj(&resolvedPath); } /* diff --git a/tests/cmdAH.test b/tests/cmdAH.test index 3aa9f71..a734541 100644 --- a/tests/cmdAH.test +++ b/tests/cmdAH.test @@ -355,7 +355,7 @@ test cmdAH-5.1 {Tcl_FileObjCmd} -returnCodes error -body { } -result {wrong # args: should be "file subcommand ?arg ...?"} test cmdAH-5.2 {Tcl_FileObjCmd} -returnCodes error -body { file x -} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, home, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "x": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, home, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, tildeexpand, type, volumes, or writable} test cmdAH-5.3 {Tcl_FileObjCmd} -returnCodes error -body { file exists } -result {wrong # args: should be "file exists name"} @@ -1686,7 +1686,7 @@ test cmdAH-29.6.1 { # Error conditions test cmdAH-30.1 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file gorp x -} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, home, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, type, volumes, or writable} +} -result {unknown or ambiguous subcommand "gorp": must be atime, attributes, channels, copy, delete, dirname, executable, exists, extension, home, isdirectory, isfile, join, link, lstat, mkdir, mtime, nativename, normalize, owned, pathtype, readable, readlink, rename, rootname, separator, size, split, stat, system, tail, tempdir, tempfile, tildeexpand, type, volumes, or writable} test cmdAH-30.2 {Tcl_FileObjCmd: error conditions} -returnCodes error -body { file ex x } -match glob -result {unknown or ambiguous subcommand "ex": must be *} diff --git a/tests/fCmd.test b/tests/fCmd.test index 72a3cd5..73118f4 100644 --- a/tests/fCmd.test +++ b/tests/fCmd.test @@ -2600,13 +2600,88 @@ test fCmd-31.6 {file home USER} -body { # name, else not sure how to check file home $::tcl_platform(user) } -match glob -result "*$::tcl_platform(user)*" -test fCmd-31.6 {file home UNKNOWNUSER} -body { +test fCmd-31.7 {file home UNKNOWNUSER} -body { file home nosuchuser } -returnCodes error -result {user "nosuchuser" doesn't exist} -test fCmd-31.7 {file home extra arg} -body { +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-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 { + set ::env(HOME) [file dirname $::env(HOME)] +} -body { + file tildeexpand ~ +} -result [file join $::env(HOME) xxx] +test fCmd-32.3 {file tildeexpand ~ - error} -setup { + set saved $::env(HOME) + unset ::env(HOME) +} -cleanup { + set ::env(HOME) $saved +} -body { + file tildeexpand ~ +} -returnCodes error -result {couldn't find HOME environment variable to expand path} +test fCmd-32.4 { + file tildeexpand ~ - relative path. Following 8.x ~ expansion behavior, relative + paths are not made absolute +} -setup { + set saved $::env(HOME) + set ::env(HOME) relative/path +} -cleanup { + set ::env(HOME) $saved +} -body { + 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 + file tildeexpand ~$::tcl_platform(user) +} -match glob -result "*$::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 + file tildeexpand ~$::tcl_platform(user)/bar +} -match glob -result "*$::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 /~$::tcl_platform(user)/foo +} -result /~$::tcl_platform(user)/foo +test fCmd-32.13 {file tildeexpand ./~} -body { + file tildeexpand ./~ +} -result ./~ +test fCmd-32.14 {file tildeexpand relative/path} -body { + file tildeexpand relative/path +} -result relative/path +test fCmd-32.15 {file tildeexpand ~\\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 + file tildeexpand ~$::tcl_platform(user)\\bar +} -constraints win -match glob -result "*$::tcl_platform(user)*/bar" + # cleanup cleanup -- cgit v0.12 From 535acd95da296aad6bce5f59b57b5d4d83291b4a Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 14 Sep 2022 17:52:43 +0000 Subject: eol-spacing --- generic/tclUniData.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/generic/tclUniData.c b/generic/tclUniData.c index d8c93f3..33bdb8e 100644 --- a/generic/tclUniData.c +++ b/generic/tclUniData.c @@ -568,7 +568,7 @@ static const unsigned short pageMap[] = { 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 1344, 15520 - + #endif /* TCL_UTF_MAX > 3 */ }; @@ -1653,7 +1653,7 @@ static const unsigned char groupMap[] = { 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 15, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 - + #endif /* TCL_UTF_MAX > 3 */ }; -- cgit v0.12