diff options
Diffstat (limited to 'generic/tclPathObj.c')
-rw-r--r-- | generic/tclPathObj.c | 247 |
1 files changed, 247 insertions, 0 deletions
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 9524f26..250ad6a 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -2559,6 +2559,253 @@ TclNativePathInFilesystem( } /* + *---------------------------------------------------------------------- + * + * MakeTildeRelativePath -- + * + * 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 + * and TCL_ERROR on failure with error message in interp if non-NULL. + * + *---------------------------------------------------------------------- + */ +int +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 dirString; + + Tcl_DStringInit(dsPtr); + Tcl_DStringInit(&dirString); + + if (user == NULL || user[0] == 0) { + /* No user name specified -> current user */ + + 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 TCL_ERROR; + } + } else { + /* User name specified - ~user */ + dir = TclpGetUserHome(user, &dirString); + 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; + } + } + 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; +} + +/* + *---------------------------------------------------------------------- + * + * TclGetHomeDirObj -- + * + * Wrapper around MakeTildeRelativePath. 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 (MakeTildeRelativePath(interp, user, NULL, &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. + * + * 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; + int split; + Tcl_DString resolvedPath; + + 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 (MakeTildeRelativePath( + interp, NULL, path[1] ? 2 + path : NULL, &resolvedPath) + != 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); + + /* 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); + } + return TclDStringToObj(&resolvedPath); +} + +/* + *---------------------------------------------------------------------- + * + * 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 |