summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclFileName.c28
-rw-r--r--generic/tclInt.h3
-rw-r--r--generic/tclPathObj.c188
-rw-r--r--unix/tclUnixInit.c16
4 files changed, 197 insertions, 38 deletions
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index b13a435..3ffdede 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -1228,34 +1228,6 @@ DoTildeSubst(
/*
*----------------------------------------------------------------------
*
- * TclResolveTildePaths --
- *
- * Given a Tcl_Obj that is a list of paths, returns a Tcl_Obj containing
- * the paths with any ~-prefixed paths resolved. Returns NULL if
- * none of the paths contained a ~-prefixed path, or passed in value
- * was not a list, or if NULL was passed in.
- *
- * ~-prefixed paths that cannot be resolved are removed from the
- * returned list.
- *
- * Results:
- * Returns a Tcl_Obj with resolved paths or NULL.
- *
- *----------------------------------------------------------------------
- */
-Tcl_Obj *TclResolveTildePaths(
- Tcl_Interp *interp,
- Tcl_Obj *pathsObj)
-{
- /* TODO */
-
- return NULL;
-}
-
-
-/*
- *----------------------------------------------------------------------
- *
* Tcl_GlobObjCmd --
*
* This procedure is invoked to process the "glob" Tcl command. See the
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 0923795..394fc54 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3020,8 +3020,9 @@ 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 Tcl_Obj * TclResolveTildePaths(Tcl_Interp *interp,
+MODULE_SCOPE Tcl_Obj * TclResolveTildePath(Tcl_Interp *interp,
Tcl_Obj *pathsObj);
+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 aff0a33..7efd14e 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -2569,6 +2569,194 @@ TclNativePathInFilesystem(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * TclResolveTildePath --
+ *
+ * If the passed Tcl_Obj 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 unmodified.
+ *
+ * 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 and reference count 0, or the
+ * original Tcl_Obj if it does not begin with a tilde. Returns NULL
+ * if the path begins with a ~ that cannot be resolved.
+ *
+ *----------------------------------------------------------------------
+ */
+Tcl_Obj *
+TclResolveTildePath(
+ Tcl_Interp *interp, /* May be NULL. Only used for error messages */
+ Tcl_Obj *pathObj)
+{
+ size_t len;
+ Tcl_Obj *resolvedObj;
+ const char *name;
+ Tcl_DString dirString;
+ size_t split;
+ char separator = '/';
+
+ /*
+ * Copied almost verbatim from the corresponding SetFsPathFromAny fragment
+ * in 8.7.
+ *
+ * First step is to translate the filename. This is similar to
+ * Tcl_TranslateFilename, but shouldn't convert everything to windows
+ * backslashes on that platform. The current implementation of this piece
+ * is a slightly optimised version of the various Tilde/Split/Join stuff
+ * to avoid multiple split/join operations.
+ *
+ * We remove any trailing directory separator.
+ *
+ * However, the split/join routines are quite complex, and one has to make
+ * sure not to break anything on Unix or Win (fCmd.test, fileName.test and
+ * cmdAH.test exercise most of the code).
+ */
+
+ name = Tcl_GetStringFromObj(pathObj, &len);
+ if (name[0] != '~') {
+ return pathObj; /* No tilde prefix, no need to resolve */
+ }
+
+ /*
+ * We have multiple cases '~/foo/bar...', '~user/foo/bar...', etc.
+ * split becomes value 1 for '~/...' as well as for '~'.
+ */
+ split = FindSplitPos(name, separator);
+
+ if (split == 1) {
+ /* No user name specified -> current user */
+
+ const char *dir;
+ Tcl_DString dirString;
+
+ Tcl_DStringInit(&dirString);
+ dir = TclGetEnv("HOME", &dirString);
+ 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 NULL;
+ }
+ } else {
+ /* User name specified - ~user */
+
+ const char *expandedUser;
+ Tcl_DString userName;
+
+ Tcl_DStringInit(&userName);
+ Tcl_DStringAppend(&userName, name+1, split-1);
+ expandedUser = Tcl_DStringValue(&userName);
+
+ Tcl_DStringInit(&dirString);
+ if (TclpGetUserHome(expandedUser, &dirString) == NULL) {
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "user \"%s\" doesn't exist", expandedUser));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER",
+ NULL);
+ }
+ Tcl_DStringFree(&userName);
+ Tcl_DStringFree(&dirString);
+ return NULL;
+ }
+ Tcl_DStringFree(&userName);
+ }
+ resolvedObj = TclDStringToObj(&dirString);
+
+ if (split < len) {
+ /* If any trailer, append it verbatim */
+ Tcl_AppendToObj(resolvedObj, split + name, 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;
+ size_t objc;
+ size_t 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) {
+ Tcl_ListObjAppendElement(NULL, resolvedPaths, resolvedPath);
+ }
+ }
+
+ return resolvedPaths;
+}
+
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c
index 9d84a21..50befc3 100644
--- a/unix/tclUnixInit.c
+++ b/unix/tclUnixInit.c
@@ -865,15 +865,13 @@ TclpSetVariables(
#ifndef TCL_TILDE_EXPAND
{
- Tcl_Obj *resolvedPaths =
- TclResolveTildePaths(interp,
- Tcl_GetVar2Ex(
- interp,
- "tcl_pkgPath",
- NULL,
- TCL_GLOBAL_ONLY));
- if (resolvedPaths) {
- Tcl_SetVar2Ex(interp, "tcl_pkgPath", NULL, resolvedPaths, TCL_GLOBAL_ONLY);
+ Tcl_Obj *origPaths;
+ Tcl_Obj *resolvedPaths;
+ origPaths = Tcl_GetVar2Ex(interp, "tcl_pkgPath", NULL, TCL_GLOBAL_ONLY);
+ resolvedPaths = TclResolveTildePathList(origPaths);
+ if (resolvedPaths != origPaths && resolvedPaths != NULL) {
+ Tcl_SetVar2Ex(interp, "tcl_pkgPath", NULL,
+ resolvedPaths, TCL_GLOBAL_ONLY);
}
}
#endif
generated by cgit v0.12 at 2025-12-09 22:44:16 (GMT)