diff options
| -rw-r--r-- | generic/tclEnv.c | 3 | ||||
| -rw-r--r-- | generic/tclFCmd.c | 8 | ||||
| -rw-r--r-- | generic/tclFileName.c | 58 | ||||
| -rw-r--r-- | generic/tclIOUtil.c | 10 | ||||
| -rw-r--r-- | generic/tclInt.h | 3 | ||||
| -rw-r--r-- | generic/tclPathObj.c | 210 | ||||
| -rw-r--r-- | library/safe.tcl | 2 | ||||
| -rw-r--r-- | unix/tclUnixInit.c | 13 | ||||
| -rw-r--r-- | win/tclWinFCmd.c | 8 |
9 files changed, 285 insertions, 30 deletions
diff --git a/generic/tclEnv.c b/generic/tclEnv.c index 73a8b84..e469fe9 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -365,6 +365,7 @@ TclSetEnv( Tcl_MutexUnlock(&envMutex); +#ifdef TCL_TILDE_EXPAND if (!strcmp(name, "HOME")) { /* * If the user's home directory has changed, we must invalidate the @@ -373,6 +374,8 @@ TclSetEnv( Tcl_FSMountsChanged(NULL); } +#endif + } /* diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index ad60146..c19623d 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -882,7 +882,8 @@ FileBasename( Tcl_IncrRefCount(splitPtr); if (objc != 0) { - if ((objc == 1) && (*TclGetString(pathPtr) == '~')) { +#ifdef TCL_TILDE_EXPAND + if ((objc == 1) && (*TclGetString(pathPtr) == '~')) { Tcl_DecrRefCount(splitPtr); if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { return NULL; @@ -890,9 +891,10 @@ FileBasename( splitPtr = Tcl_FSSplitPath(pathPtr, &objc); Tcl_IncrRefCount(splitPtr); } +#endif - /* - * Return the last component, unless it is the only component, and it + /* + * Return the last component, unless it is the only component, and it * is the root of an absolute path. */ diff --git a/generic/tclFileName.c b/generic/tclFileName.c index dba137c..3ffdede 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -362,6 +362,7 @@ Tcl_GetPathType( * file). The exported function Tcl_FSGetPathType should be used by * extensions. * + * If TCL_TILDE_EXPAND defined: * Note that '~' paths are always considered TCL_PATH_ABSOLUTE, even * though expanding the '~' could lead to any possible path type. This * function should therefore be considered a low-level, string @@ -389,8 +390,9 @@ TclpGetNativePathType( const char *path = TclGetString(pathPtr); if (path[0] == '~') { - /* - * This case is common to all platforms. Paths that begin with ~ are +#ifdef TCL_TILDE_EXPAND + /* + * This case is common to all platforms. Paths that begin with ~ are * absolute. */ @@ -401,6 +403,9 @@ TclpGetNativePathType( } *driveNameLengthPtr = end - path; } +#else + type = TCL_PATH_RELATIVE; +#endif } else { switch (tclPlatform) { case TCL_PLATFORM_UNIX: { @@ -697,13 +702,17 @@ SplitUnixPath( length = path - elementStart; if (length > 0) { Tcl_Obj *nextElt; - if ((elementStart[0] == '~') && (elementStart != origPath)) { +#ifdef TCL_TILDE_EXPAND + if ((elementStart[0] == '~') && (elementStart != origPath)) { TclNewLiteralStringObj(nextElt, "./"); Tcl_AppendToObj(nextElt, elementStart, length); } else { nextElt = Tcl_NewStringObj(elementStart, length); } - Tcl_ListObjAppendElement(NULL, result, nextElt); +#else + nextElt = Tcl_NewStringObj(elementStart, length); +#endif + Tcl_ListObjAppendElement(NULL, result, nextElt); } if (*path++ == '\0') { break; @@ -766,10 +775,13 @@ SplitWinPath( length = p - elementStart; if (length > 0) { Tcl_Obj *nextElt; - if ((elementStart != path) && ((elementStart[0] == '~') - || (isalpha(UCHAR(elementStart[0])) - && elementStart[1] == ':'))) { - TclNewLiteralStringObj(nextElt, "./"); + if ((elementStart != path) && + ( +#ifdef TCL_TILDE_EXPAND + (elementStart[0] == '~') || +#endif + (isalpha(UCHAR(elementStart[0])) && elementStart[1] == ':'))) { + TclNewLiteralStringObj(nextElt, "./"); Tcl_AppendToObj(nextElt, elementStart, length); } else { nextElt = Tcl_NewStringObj(elementStart, length); @@ -871,9 +883,15 @@ TclpNativeJoinPath( p = joining; if (length != 0) { - if ((p[0] == '.') && (p[1] == '/') && ((p[2] == '~') - || (tclPlatform==TCL_PLATFORM_WINDOWS && isalpha(UCHAR(p[2])) - && (p[3] == ':')))) { + if ((p[0] == '.') && + (p[1] == '/') && + ( +#ifdef TCL_TILDE_EXPAND + (p[2] == '~') || +#endif + (tclPlatform==TCL_PLATFORM_WINDOWS && + isalpha(UCHAR(p[2])) && + (p[3] == ':')))) { p += 2; } } @@ -1146,6 +1164,7 @@ TclGetExtension( return p; } +#ifdef TCL_TILDE_EXPAND /* *---------------------------------------------------------------------- * @@ -1204,6 +1223,7 @@ DoTildeSubst( } return Tcl_DStringValue(resultPtr); } +#endif /* TCL_TILDE_EXPAND */ /* *---------------------------------------------------------------------- @@ -1729,7 +1749,6 @@ TclGlob( * NULL. */ { const char *separators; - const char *head; char *tail, *start; int result; Tcl_Obj *filenamesObj, *savedResultObj; @@ -1745,7 +1764,6 @@ TclGlob( } if (pathPrefix == NULL) { - char c; Tcl_DString buffer; Tcl_DStringInit(&buffer); @@ -1755,7 +1773,10 @@ TclGlob( * Perform tilde substitution, if needed. */ - if (start[0] == '~') { +#ifdef TCL_TILDE_EXPAND + if (start[0] == '~') { + const char *head; + char c; /* * Find the first path separator after the tilde. */ @@ -1794,6 +1815,9 @@ TclGlob( } else { tail = pattern; } +#else + tail = pattern; +#endif /* TCL_TILDE_EXPAND */ } else { Tcl_IncrRefCount(pathPrefix); tail = pattern; @@ -2351,14 +2375,16 @@ DoGlob( for (i=0; result==TCL_OK && i<subdirc; i++) { Tcl_Obj *copy = NULL; - if (pathPtr == NULL && TclGetString(subdirv[i])[0] == '~') { +#ifdef TCL_TILDE_EXPAND + if (pathPtr == NULL && TclGetString(subdirv[i])[0] == '~') { TclListObjLengthM(NULL, matchesObj, &repair); copy = subdirv[i]; subdirv[i] = Tcl_NewStringObj("./", 2); Tcl_AppendObjToObj(subdirv[i], copy); Tcl_IncrRefCount(subdirv[i]); } - result = DoGlob(interp, matchesObj, separators, subdirv[i], +#endif /* TCL_TILDE_EXPAND */ + result = DoGlob(interp, matchesObj, separators, subdirv[i], 1, p+1, types); if (copy) { size_t end; diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index d51491f..50346b6 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -1215,7 +1215,7 @@ FsAddMountsToGlobResult( * (4) The mapping from a string representation of a file to a full, * normalized pathname changes. For example, if 'env(HOME)' is modified, * then any pathname containing '~' maps to a different item, possibly in - * a different filesystem. + * a different filesystem. (Only if TCL_TILDE_EXPAND is defined) * * Tcl has no control over (2) and (3), so each registered filesystem must * call Tcl_FSMountsChnaged in each of those circumstances. @@ -3939,13 +3939,17 @@ Tcl_FSSplitPath( if (length > 0) { Tcl_Obj *nextElt; - if (elementStart[0] == '~') { +#ifdef TCL_TILDE_EXPAND + if (elementStart[0] == '~') { TclNewLiteralStringObj(nextElt, "./"); Tcl_AppendToObj(nextElt, elementStart, length); } else { nextElt = Tcl_NewStringObj(elementStart, length); } - Tcl_ListObjAppendElement(NULL, result, nextElt); +#else + nextElt = Tcl_NewStringObj(elementStart, length); +#endif /* TCL_TILDE_EXPAND */ + Tcl_ListObjAppendElement(NULL, result, nextElt); } if (*p++ == '\0') { break; diff --git a/generic/tclInt.h b/generic/tclInt.h index b6d5b9a..69b18b1 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -3020,6 +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 * 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 f7da276..7efd14e 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -699,7 +699,8 @@ TclPathPart( splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements); Tcl_IncrRefCount(splitPtr); - if (splitElements == 1 && TclGetString(pathPtr)[0] == '~') { +#ifdef TCL_TILDE_EXPAND + if (splitElements == 1 && TclGetString(pathPtr)[0] == '~') { Tcl_Obj *norm; TclDecrRefCount(splitPtr); @@ -710,7 +711,8 @@ TclPathPart( splitPtr = Tcl_FSSplitPath(norm, &splitElements); Tcl_IncrRefCount(splitPtr); } - if (portion == TCL_PATH_TAIL) { +#endif /* TCL_TILDE_EXPAND */ + if (portion == TCL_PATH_TAIL) { /* * Return the last component, unless it is the only component, and * it is the root of an absolute path. @@ -1038,8 +1040,9 @@ TclJoinPath( } ptr = Tcl_GetStringFromObj(res, &length); - /* - * Strip off any './' before a tilde, unless this is the beginning of +#ifdef TCL_TILDE_EXPAND + /* + * Strip off any './' before a tilde, unless this is the beginning of * the path. */ @@ -1047,9 +1050,10 @@ TclJoinPath( (strElt[1] == '/') && (strElt[2] == '~')) { strElt += 2; } +#endif /* TCL_TILDE_EXPAND */ - /* - * A NULL value for fsPtr at this stage basically means we're trying + /* + * A NULL value for fsPtr at this stage basically means we're trying * to join a relative path onto something which is also relative (or * empty). There's nothing particularly wrong with that. */ @@ -1246,6 +1250,7 @@ TclNewFSPathObj( const char *p; int state = 0, count = 0; +#ifdef TCL_TILDE_EXPAND /* [Bug 2806250] - this is only a partial solution of the problem. * The PATHFLAGS != 0 representation assumes in many places that * the "tail" part stored in the normPathPtr field is itself a @@ -1269,6 +1274,7 @@ TclNewFSPathObj( Tcl_DecrRefCount(tail); return pathPtr; } +#endif /* TCL_TILDE_EXPAND */ TclNewObj(pathPtr); fsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath)); @@ -2230,6 +2236,7 @@ SetFsPathFromAny( * Handle tilde substitutions, if needed. */ +#ifdef TCL_TILDE_EXPAND if (len && name[0] == '~') { Tcl_DString temp; size_t split; @@ -2341,6 +2348,9 @@ SetFsPathFromAny( } else { transPtr = TclJoinPath(1, &pathPtr, 1); } +#else + transPtr = TclJoinPath(1, &pathPtr, 1); +#endif /* TCL_TILDE_EXPAND */ /* * Now we have a translated filename in 'transPtr'. This will have forward @@ -2559,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/library/safe.tcl b/library/safe.tcl index 6c905fb..09c82e5 100644 --- a/library/safe.tcl +++ b/library/safe.tcl @@ -733,6 +733,8 @@ proc ::safe::CheckFileName {child file} { # prevent discovery of what home directories exist. proc ::safe::AliasFileSubcommand {child subcommand name} { + # TODO - if TIP602 is accepted for Tcl9, this check could be removed. + # The check is required if TCL_TILDE_EXPAND is defined. if {[string match ~* $name]} { set name ./$name } diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c index cd84081..cb74630 100644 --- a/unix/tclUnixInit.c +++ b/unix/tclUnixInit.c @@ -863,6 +863,19 @@ TclpSetVariables( Tcl_SetVar2(interp, "tcl_pkgPath", NULL, pkgPath, TCL_GLOBAL_ONLY); } +#ifndef TCL_TILDE_EXPAND + { + 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 + #ifdef DJGPP Tcl_SetVar2(interp, "tcl_platform", "platform", "dos", TCL_GLOBAL_ONLY); #else diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c index a5d659e..5f55354 100644 --- a/win/tclWinFCmd.c +++ b/win/tclWinFCmd.c @@ -1719,7 +1719,8 @@ ConvertFileNameFormat( * Deal with issues of tildes being absolute. */ - if (Tcl_DStringValue(&dsTemp)[0] == '~') { +#ifdef TCL_TILDE_EXPAND + if (Tcl_DStringValue(&dsTemp)[0] == '~') { TclNewLiteralStringObj(tempPath, "./"); Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp), Tcl_DStringLength(&dsTemp)); @@ -1727,7 +1728,10 @@ ConvertFileNameFormat( } else { tempPath = TclDStringToObj(&dsTemp); } - Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath); +#else + tempPath = TclDStringToObj(&dsTemp); +#endif /* TCL_TILDE_EXPAND */ + Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath); FindClose(handle); } } |