summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclCmdAH.c3
-rw-r--r--generic/tclFCmd.c38
-rw-r--r--generic/tclInt.h5
-rw-r--r--generic/tclPathObj.c80
-rw-r--r--tests/fCmd.test79
5 files changed, 164 insertions, 41 deletions
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index eec3e0f..bf7a9cd 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -1045,7 +1045,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},
@@ -1069,6 +1069,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 d7fa750..6bf34d8 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -1680,6 +1680,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 51f7e75..183838d 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2913,6 +2913,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,
void *clientData);
MODULE_SCOPE void TclDeleteLateExitHandler(Tcl_ExitProc *proc,
@@ -3021,8 +3022,8 @@ MODULE_SCOPE int TclIsDigitProc(int byte);
MODULE_SCOPE int TclIsBareword(int byte);
MODULE_SCOPE Tcl_Obj * TclJoinPath(size_t 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 82b79f5..2fbeea3 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -2422,11 +2422,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
@@ -2435,22 +2441,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(
@@ -2463,7 +2470,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(
@@ -2474,7 +2481,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;
}
@@ -2484,7 +2500,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
@@ -2499,7 +2515,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);
@@ -2515,12 +2531,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
@@ -2537,9 +2547,8 @@ TclResolveTildePath(
{
const char *path;
size_t len;
- Tcl_Obj *resolvedObj;
- Tcl_DString dirString;
size_t split;
+ Tcl_DString resolvedPath;
path = Tcl_GetStringFromObj(pathObj, &len);
if (path[0] != '~') {
@@ -2556,12 +2565,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;
@@ -2569,20 +2579,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/fCmd.test b/tests/fCmd.test
index e9d7667..dbbc154 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -2699,13 +2699,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
generated by cgit v0.12 at 2024-11-16 07:49:42 (GMT)