diff options
Diffstat (limited to 'generic/tclFileName.c')
| -rw-r--r-- | generic/tclFileName.c | 991 |
1 files changed, 587 insertions, 404 deletions
diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 0bf1754..5d4702b 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -9,8 +9,6 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclFileName.c,v 1.71 2005/07/17 21:17:40 dkf Exp $ */ #include "tclInt.h" @@ -28,18 +26,57 @@ TclPlatformType tclPlatform = TCL_PLATFORM_UNIX; * Prototypes for local procedures defined in this file: */ -static CONST char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp, - CONST char *user, Tcl_DString *resultPtr)); -static CONST char * ExtractWinRoot _ANSI_ARGS_((CONST char *path, +static const char * DoTildeSubst(Tcl_Interp *interp, + const char *user, Tcl_DString *resultPtr); +static const char * ExtractWinRoot(const char *path, Tcl_DString *resultPtr, int offset, - Tcl_PathType *typePtr)); -static int SkipToChar _ANSI_ARGS_((char **stringPtr, int match)); -static Tcl_Obj* SplitWinPath _ANSI_ARGS_((CONST char *path)); -static Tcl_Obj* SplitUnixPath _ANSI_ARGS_((CONST char *path)); -static int DoGlob _ANSI_ARGS_((Tcl_Interp *interp, - Tcl_Obj *resultPtr, char *separators, - Tcl_Obj *pathPtr, int flags, char *pattern, - Tcl_GlobTypeData *types)); + Tcl_PathType *typePtr); +static int SkipToChar(char **stringPtr, int match); +static Tcl_Obj * SplitWinPath(const char *path); +static Tcl_Obj * SplitUnixPath(const char *path); +static int DoGlob(Tcl_Interp *interp, Tcl_Obj *resultPtr, + const char *separators, Tcl_Obj *pathPtr, int flags, + char *pattern, Tcl_GlobTypeData *types); + +/* + * When there is no support for getting the block size of a file in a stat() + * call, use this as a guess. Allow it to be overridden in the platform- + * specific files. + */ + +#if (!defined(HAVE_STRUCT_STAT_ST_BLKSIZE) && !defined(GUESSED_BLOCK_SIZE)) +#define GUESSED_BLOCK_SIZE 1024 +#endif + +/* + *---------------------------------------------------------------------- + * + * SetResultLength -- + * + * Resets the result DString for ExtractWinRoot to accommodate + * any NT extended path prefixes. + * + * Results: + * None. + * + * Side effects: + * May modify the Tcl_DString. + *---------------------------------------------------------------------- + */ + +static void +SetResultLength( + Tcl_DString *resultPtr, + int offset, + int extended) +{ + Tcl_DStringSetLength(resultPtr, offset); + if (extended == 2) { + TclDStringAppendLiteral(resultPtr, "//?/UNC/"); + } else if (extended == 1) { + TclDStringAppendLiteral(resultPtr, "//?/"); + } +} /* *---------------------------------------------------------------------- @@ -51,7 +88,7 @@ static int DoGlob _ANSI_ARGS_((Tcl_Interp *interp, * * Results: * Returns the position in the path immediately after the root including - * any trailing slashes. Appends a cleaned up version of the root to the + * any trailing slashes. Appends a cleaned up version of the root to the * Tcl_DString at the specified offest. * * Side effects: @@ -60,26 +97,41 @@ static int DoGlob _ANSI_ARGS_((Tcl_Interp *interp, *---------------------------------------------------------------------- */ -static CONST char * -ExtractWinRoot(path, resultPtr, offset, typePtr) - CONST char *path; /* Path to parse. */ - Tcl_DString *resultPtr; /* Buffer to hold result. */ - int offset; /* Offset in buffer where result should be +static const char * +ExtractWinRoot( + const char *path, /* Path to parse. */ + Tcl_DString *resultPtr, /* Buffer to hold result. */ + int offset, /* Offset in buffer where result should be * stored. */ - Tcl_PathType *typePtr; /* Where to store pathType result */ + Tcl_PathType *typePtr) /* Where to store pathType result */ { + int extended = 0; + + if ( (path[0] == '/' || path[0] == '\\') + && (path[1] == '/' || path[1] == '\\') + && (path[2] == '?') + && (path[3] == '/' || path[3] == '\\')) { + extended = 1; + path = path + 4; + if (path[0] == 'U' && path[1] == 'N' && path[2] == 'C' + && (path[3] == '/' || path[3] == '\\')) { + extended = 2; + path = path + 4; + } + } + if (path[0] == '/' || path[0] == '\\') { /* * Might be a UNC or Vol-Relative path. */ - CONST char *host, *share, *tail; + const char *host, *share, *tail; int hlen, slen; if (path[1] != '/' && path[1] != '\\') { - Tcl_DStringSetLength(resultPtr, offset); + SetResultLength(resultPtr, offset, extended); *typePtr = TCL_PATH_VOLUME_RELATIVE; - Tcl_DStringAppend(resultPtr, "/", 1); + TclDStringAppendLiteral(resultPtr, "/"); return &path[1]; } host = &path[2]; @@ -100,19 +152,19 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) if (host[hlen] == 0 || host[hlen+1] == 0) { /* * The path given is simply of the form '/foo', '//foo', - * '/////foo' or the same with backslashes. If there is exactly + * '/////foo' or the same with backslashes. If there is exactly * one leading '/' the path is volume relative (see filename man - * page). If there are more than one, we are simply assuming they - * are superfluous and we trim them away. (An alternative + * page). If there are more than one, we are simply assuming they + * are superfluous and we trim them away. (An alternative * interpretation would be that it is a host name, but we have * been documented that that is not the case). */ *typePtr = TCL_PATH_VOLUME_RELATIVE; - Tcl_DStringAppend(resultPtr, "/", 1); + TclDStringAppendLiteral(resultPtr, "/"); return &path[2]; } - Tcl_DStringSetLength(resultPtr, offset); + SetResultLength(resultPtr, offset, extended); share = &host[hlen]; /* @@ -128,9 +180,9 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) break; } } - Tcl_DStringAppend(resultPtr, "//", 2); + TclDStringAppendLiteral(resultPtr, "//"); Tcl_DStringAppend(resultPtr, host, hlen); - Tcl_DStringAppend(resultPtr, "/", 1); + TclDStringAppendLiteral(resultPtr, "/"); Tcl_DStringAppend(resultPtr, share, slen); tail = &share[slen]; @@ -150,14 +202,14 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) * Might be a drive separator. */ - Tcl_DStringSetLength(resultPtr, offset); + SetResultLength(resultPtr, offset, extended); if (path[2] != '/' && path[2] != '\\') { *typePtr = TCL_PATH_VOLUME_RELATIVE; Tcl_DStringAppend(resultPtr, path, 2); return &path[2]; } else { - char *tail = (char*)&path[3]; + const char *tail = &path[3]; /* * Skip separators. @@ -169,7 +221,7 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) *typePtr = TCL_PATH_ABSOLUTE; Tcl_DStringAppend(resultPtr, path, 2); - Tcl_DStringAppend(resultPtr, "/", 1); + TclDStringAppendLiteral(resultPtr, "/"); return tail; } @@ -249,7 +301,7 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) if (abs != 0) { *typePtr = TCL_PATH_ABSOLUTE; - Tcl_DStringSetLength(resultPtr, offset); + SetResultLength(resultPtr, offset, extended); Tcl_DStringAppend(resultPtr, path, abs); return path + abs; } @@ -286,8 +338,8 @@ ExtractWinRoot(path, resultPtr, offset, typePtr) */ Tcl_PathType -Tcl_GetPathType(path) - CONST char *path; +Tcl_GetPathType( + const char *path) { Tcl_PathType type; Tcl_Obj *tempObj = Tcl_NewStringObj(path,-1); @@ -307,11 +359,11 @@ Tcl_GetPathType(path) * relative to the current volume, or absolute, but ONLY FOR THE NATIVE * FILESYSTEM. This function is called from tclIOUtil.c (but needs to be * here due to its dependence on static variables/functions in this - * file). The exported function Tcl_FSGetPathType should be used by + * file). The exported function Tcl_FSGetPathType should be used by * extensions. * * Note that '~' paths are always considered TCL_PATH_ABSOLUTE, even - * though expanding the '~' could lead to any possible path type. This + * though expanding the '~' could lead to any possible path type. This * function should therefore be considered a low-level, string * manipulation function only -- it doesn't actually do any expansion in * making its determination. @@ -327,24 +379,24 @@ Tcl_GetPathType(path) */ Tcl_PathType -TclpGetNativePathType(pathPtr, driveNameLengthPtr, driveNameRef) - Tcl_Obj *pathPtr; /* Native path of interest */ - int *driveNameLengthPtr; /* Returns length of drive, if non-NULL and +TclpGetNativePathType( + Tcl_Obj *pathPtr, /* Native path of interest */ + int *driveNameLengthPtr, /* Returns length of drive, if non-NULL and * path was absolute */ - Tcl_Obj **driveNameRef; + Tcl_Obj **driveNameRef) { Tcl_PathType type = TCL_PATH_ABSOLUTE; int pathLen; - char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); + const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); if (path[0] == '~') { /* - * This case is common to all platforms. Paths that begin with ~ are + * This case is common to all platforms. Paths that begin with ~ are * absolute. */ if (driveNameLengthPtr != NULL) { - char *end = path + 1; + const char *end = path + 1; while ((*end != '\0') && (*end != '/')) { end++; } @@ -353,31 +405,42 @@ TclpGetNativePathType(pathPtr, driveNameLengthPtr, driveNameRef) } else { switch (tclPlatform) { case TCL_PLATFORM_UNIX: { - char *origPath = path; + const char *origPath = path; /* * Paths that begin with / are absolute. */ -#ifdef __QNX__ - /* - * Check for QNX //<node id> prefix - */ - if (*path && (pathLen > 3) && (path[0] == '/') - && (path[1] == '/') && isdigit(UCHAR(path[2]))) { - path += 3; - while (isdigit(UCHAR(*path))) { - ++path; + if (path[0] == '/') { + ++path; +#if defined(__CYGWIN__) || defined(__QNX__) + /* + * Check for "//" network path prefix + */ + if ((*path == '/') && path[1] && (path[1] != '/')) { + path += 2; + while (*path && *path != '/') { + ++path; + } +#if defined(__CYGWIN__) + /* UNC paths need to be followed by a share name */ + if (*path++ && (*path && *path != '/')) { + ++path; + while (*path && *path != '/') { + ++path; + } + } else { + path = origPath + 1; + } +#endif } - } #endif - if (path[0] == '/') { if (driveNameLengthPtr != NULL) { /* - * We need this addition in case the QNX code was used. + * We need this addition in case the QNX or Cygwin code was used. */ - *driveNameLengthPtr = (1 + path - origPath); + *driveNameLengthPtr = (path - origPath); } } else { type = TCL_PATH_RELATIVE; @@ -386,15 +449,14 @@ TclpGetNativePathType(pathPtr, driveNameLengthPtr, driveNameRef) } case TCL_PLATFORM_WINDOWS: { Tcl_DString ds; - CONST char *rootEnd; + const char *rootEnd; Tcl_DStringInit(&ds); rootEnd = ExtractWinRoot(path, &ds, 0, &type); if ((rootEnd != path) && (driveNameLengthPtr != NULL)) { *driveNameLengthPtr = rootEnd - path; if (driveNameRef != NULL) { - *driveNameRef = Tcl_NewStringObj(Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds)); + *driveNameRef = TclDStringToObj(&ds); Tcl_IncrRefCount(*driveNameRef); } } @@ -419,7 +481,7 @@ TclpGetNativePathType(pathPtr, driveNameLengthPtr, driveNameRef) * functions, which require more memory allocation than is desirable. * * Results: - * Returns list object with refCount of zero. If the passed in lenPtr is + * Returns list object with refCount of zero. If the passed in lenPtr is * non-NULL, we use it to return the number of elements in the returned * list. * @@ -429,12 +491,12 @@ TclpGetNativePathType(pathPtr, driveNameLengthPtr, driveNameRef) *--------------------------------------------------------------------------- */ -Tcl_Obj* -TclpNativeSplitPath(pathPtr, lenPtr) - Tcl_Obj *pathPtr; /* Path to split. */ - int *lenPtr; /* int to store number of path elements. */ +Tcl_Obj * +TclpNativeSplitPath( + Tcl_Obj *pathPtr, /* Path to split. */ + int *lenPtr) /* int to store number of path elements. */ { - Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */ + Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */ /* * Perform platform specific splitting. @@ -465,17 +527,17 @@ TclpNativeSplitPath(pathPtr, lenPtr) * * Tcl_SplitPath -- * - * Split a path into a list of path components. The first element of the + * Split a path into a list of path components. The first element of the * list will have the same path type as the original path. * * Results: - * Returns a standard Tcl result. The interpreter result contains a list - * of path components. *argvPtr will be filled in with the address of an + * Returns a standard Tcl result. The interpreter result contains a list + * of path components. *argvPtr will be filled in with the address of an * array whose elements point to the elements of path, in order. * *argcPtr will get filled in with the number of valid elements in the - * array. A single block of memory is dynamically allocated to hold both - * the argv array and a copy of the path elements. The caller must - * eventually free this memory by calling ckfree() on *argvPtr. Note: + * array. A single block of memory is dynamically allocated to hold both + * the argv array and a copy of the path elements. The caller must + * eventually free this memory by calling ckfree() on *argvPtr. Note: * *argvPtr and *argcPtr are only modified if the procedure returns * normally. * @@ -486,17 +548,18 @@ TclpNativeSplitPath(pathPtr, lenPtr) */ void -Tcl_SplitPath(path, argcPtr, argvPtr) - CONST char *path; /* Pointer to string containing a path. */ - int *argcPtr; /* Pointer to location to fill in with the +Tcl_SplitPath( + const char *path, /* Pointer to string containing a path. */ + int *argcPtr, /* Pointer to location to fill in with the * number of elements in the path. */ - CONST char ***argvPtr; /* Pointer to place to store pointer to array + const char ***argvPtr) /* Pointer to place to store pointer to array * of pointers to path elements. */ { - Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */ + Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */ Tcl_Obj *tmpPtr, *eltPtr; int i, size, len; - char *p, *str; + char *p; + const char *str; /* * Perform the splitting, using objectified, vfs-aware code. @@ -524,8 +587,7 @@ Tcl_SplitPath(path, argcPtr, argvPtr) * plus the argv pointers and the terminating NULL pointer. */ - *argvPtr = (CONST char **) ckalloc((unsigned) - ((((*argcPtr) + 1) * sizeof(char *)) + size)); + *argvPtr = ckalloc((((*argcPtr) + 1) * sizeof(char *)) + size); /* * Position p after the last argv pointer and copy the contents of the @@ -536,7 +598,7 @@ Tcl_SplitPath(path, argcPtr, argvPtr) for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); str = Tcl_GetStringFromObj(eltPtr, &len); - memcpy((VOID *) p, (VOID *) str, (size_t) len+1); + memcpy(p, str, (size_t) len+1); p += len+1; } @@ -576,60 +638,72 @@ Tcl_SplitPath(path, argcPtr, argvPtr) *---------------------------------------------------------------------- */ -static Tcl_Obj* -SplitUnixPath(path) - CONST char *path; /* Pointer to string containing a path. */ +static Tcl_Obj * +SplitUnixPath( + const char *path) /* Pointer to string containing a path. */ { int length; - CONST char *p, *elementStart; + const char *origPath = path, *elementStart; Tcl_Obj *result = Tcl_NewObj(); /* * Deal with the root directory as a special case. */ -#ifdef __QNX__ - /* - * Check for QNX //<node id> prefix - */ - if ((path[0] == '/') && (path[1] == '/') - && isdigit(UCHAR(path[2]))) { /* INTL: digit */ - path += 3; - while (isdigit(UCHAR(*path))) { /* INTL: digit */ - ++path; + if (*path == '/') { + Tcl_Obj *rootElt; + ++path; +#if defined(__CYGWIN__) || defined(__QNX__) + /* + * Check for "//" network path prefix + */ + if ((*path == '/') && path[1] && (path[1] != '/')) { + path += 2; + while (*path && *path != '/') { + ++path; + } +#if defined(__CYGWIN__) + /* UNC paths need to be followed by a share name */ + if (*path++ && (*path && *path != '/')) { + ++path; + while (*path && *path != '/') { + ++path; + } + } else { + path = origPath + 1; + } +#endif } - } #endif - - if (path[0] == '/') { - Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj("/",1)); - p = path+1; - } else { - p = path; + rootElt = Tcl_NewStringObj(origPath, path - origPath); + Tcl_ListObjAppendElement(NULL, result, rootElt); + while (*path == '/') { + ++path; + } } /* - * Split on slashes. Embedded elements that start with tilde will be + * Split on slashes. Embedded elements that start with tilde will be * prefixed with "./" so they are not affected by tilde substitution. */ for (;;) { - elementStart = p; - while ((*p != '\0') && (*p != '/')) { - p++; + elementStart = path; + while ((*path != '\0') && (*path != '/')) { + path++; } - length = p - elementStart; + length = path - elementStart; if (length > 0) { Tcl_Obj *nextElt; - if ((elementStart[0] == '~') && (elementStart != path)) { - nextElt = Tcl_NewStringObj("./",2); + if ((elementStart[0] == '~') && (elementStart != origPath)) { + TclNewLiteralStringObj(nextElt, "./"); Tcl_AppendToObj(nextElt, elementStart, length); } else { nextElt = Tcl_NewStringObj(elementStart, length); } Tcl_ListObjAppendElement(NULL, result, nextElt); } - if (*p++ == '\0') { + if (*path++ == '\0') { break; } } @@ -653,12 +727,12 @@ SplitUnixPath(path) *---------------------------------------------------------------------- */ -static Tcl_Obj* -SplitWinPath(path) - CONST char *path; /* Pointer to string containing a path. */ +static Tcl_Obj * +SplitWinPath( + const char *path) /* Pointer to string containing a path. */ { int length; - CONST char *p, *elementStart; + const char *p, *elementStart; Tcl_PathType type = TCL_PATH_ABSOLUTE; Tcl_DString buf; Tcl_Obj *result = Tcl_NewObj(); @@ -671,13 +745,12 @@ SplitWinPath(path) */ if (p != path) { - Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj( - Tcl_DStringValue(&buf), Tcl_DStringLength(&buf))); + Tcl_ListObjAppendElement(NULL, result, TclDStringToObj(&buf)); } Tcl_DStringFree(&buf); /* - * Split on slashes. Embedded elements that start with tilde or a drive + * Split on slashes. Embedded elements that start with tilde or a drive * letter will be prefixed with "./" so they are not affected by tilde * substitution. */ @@ -690,11 +763,10 @@ SplitWinPath(path) length = p - elementStart; if (length > 0) { Tcl_Obj *nextElt; - if ((elementStart != path) - && ((elementStart[0] == '~') + if ((elementStart != path) && ((elementStart[0] == '~') || (isalpha(UCHAR(elementStart[0])) && elementStart[1] == ':'))) { - nextElt = Tcl_NewStringObj("./",2); + TclNewLiteralStringObj(nextElt, "./"); Tcl_AppendToObj(nextElt, elementStart, length); } else { nextElt = Tcl_NewStringObj(elementStart, length); @@ -730,37 +802,33 @@ SplitWinPath(path) */ Tcl_Obj * -Tcl_FSJoinToPath(pathPtr, objc, objv) - Tcl_Obj *pathPtr; /* Valid path or NULL. */ - int objc; /* Number of array elements to join */ - Tcl_Obj *CONST objv[]; /* Path elements to join. */ +Tcl_FSJoinToPath( + Tcl_Obj *pathPtr, /* Valid path or NULL. */ + int objc, /* Number of array elements to join */ + Tcl_Obj *const objv[]) /* Path elements to join. */ { - int i; - Tcl_Obj *lobj, *ret; - if (pathPtr == NULL) { - lobj = Tcl_NewListObj(0, NULL); - } else { - lobj = Tcl_NewListObj(1, &pathPtr); + return TclJoinPath(objc, objv); } - - for (i = 0; i<objc;i++) { - Tcl_ListObjAppendElement(NULL, lobj, objv[i]); + if (objc == 0) { + return TclJoinPath(1, &pathPtr); } - ret = Tcl_FSJoinPath(lobj, -1); + if (objc == 1) { + Tcl_Obj *pair[2]; - /* - * It is possible that 'ret' is just a member of the list and is therefore - * going to be freed here. Therefore we must adjust the refCount manually. - * (It would be better if we changed the documentation of this function - * and Tcl_FSJoinPath so that the returned object already has a refCount - * for the caller, hence avoiding these subtleties (and code ugliness)). - */ - - Tcl_IncrRefCount(ret); - Tcl_DecrRefCount(lobj); - ret->refCount--; - return ret; + pair[0] = pathPtr; + pair[1] = objv[0]; + return TclJoinPath(2, pair); + } else { + int elemc = objc + 1; + Tcl_Obj *ret, **elemv = ckalloc(elemc*sizeof(Tcl_Obj **)); + + elemv[0] = pathPtr; + memcpy(elemv+1, objv, objc*sizeof(Tcl_Obj **)); + ret = TclJoinPath(elemc, elemv); + ckfree(elemv); + return ret; + } } /* @@ -780,12 +848,14 @@ Tcl_FSJoinToPath(pathPtr, objc, objv) */ void -TclpNativeJoinPath(prefix, joining) - Tcl_Obj *prefix; - char *joining; +TclpNativeJoinPath( + Tcl_Obj *prefix, + const char *joining) { int length, needsSep; - char *dest, *p, *start; + char *dest; + const char *p; + const char *start; start = Tcl_GetStringFromObj(prefix, &length); @@ -815,7 +885,7 @@ TclpNativeJoinPath(prefix, joining) if (length > 0 && (start[length-1] != '/')) { Tcl_AppendToObj(prefix, "/", 1); - length++; + Tcl_GetStringFromObj(prefix, &length); } needsSep = 0; @@ -851,7 +921,7 @@ TclpNativeJoinPath(prefix, joining) if ((length > 0) && (start[length-1] != '/') && (start[length-1] != ':')) { Tcl_AppendToObj(prefix, "/", 1); - length++; + Tcl_GetStringFromObj(prefix, &length); } needsSep = 0; @@ -886,12 +956,12 @@ TclpNativeJoinPath(prefix, joining) * * Tcl_JoinPath -- * - * Combine a list of paths in a platform specific manner. The function + * Combine a list of paths in a platform specific manner. The function * 'Tcl_FSJoinPath' should be used in preference where possible. * * Results: * Appends the joined path to the end of the specified Tcl_DString - * returning a pointer to the resulting string. Note that the + * returning a pointer to the resulting string. Note that the * Tcl_DString must already be initialized. * * Side effects: @@ -901,15 +971,15 @@ TclpNativeJoinPath(prefix, joining) */ char * -Tcl_JoinPath(argc, argv, resultPtr) - int argc; - CONST char * CONST *argv; - Tcl_DString *resultPtr; /* Pointer to previously initialized DString */ +Tcl_JoinPath( + int argc, + const char *const *argv, + Tcl_DString *resultPtr) /* Pointer to previously initialized DString */ { int i, len; Tcl_Obj *listObj = Tcl_NewObj(); Tcl_Obj *resultObj; - char *resultStr; + const char *resultStr; /* * Build the list of paths. @@ -950,7 +1020,7 @@ Tcl_JoinPath(argc, argv, resultPtr) * Tcl_TranslateFileName -- * * Converts a file name into a form usable by the native system - * interfaces. If the name starts with a tilde, it will produce a name + * interfaces. If the name starts with a tilde, it will produce a name * where the tilde and following characters have been replaced by the * home directory location for the named user. * @@ -971,14 +1041,14 @@ Tcl_JoinPath(argc, argv, resultPtr) */ char * -Tcl_TranslateFileName(interp, name, bufferPtr) - Tcl_Interp *interp; /* Interpreter in which to store error message +Tcl_TranslateFileName( + Tcl_Interp *interp, /* Interpreter in which to store error message * (if necessary). */ - CONST char *name; /* File name, which may begin with "~" (to + const char *name, /* File name, which may begin with "~" (to * indicate current user's home directory) or * "~<user>" (to indicate any user's home * directory). */ - Tcl_DString *bufferPtr; /* Uninitialized or free DString filled with + Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with * name after tilde substitution. */ { Tcl_Obj *path = Tcl_NewStringObj(name, -1); @@ -992,7 +1062,7 @@ Tcl_TranslateFileName(interp, name, bufferPtr) } Tcl_DStringInit(bufferPtr); - Tcl_DStringAppend(bufferPtr, Tcl_GetString(transPtr), -1); + TclDStringAppendObj(bufferPtr, transPtr); Tcl_DecrRefCount(path); Tcl_DecrRefCount(transPtr); @@ -1023,7 +1093,7 @@ Tcl_TranslateFileName(interp, name, bufferPtr) * * Results: * Returns a pointer into name which indicates where the extension - * starts. If there is no extension, returns NULL. + * starts. If there is no extension, returns NULL. * * Side effects: * None. @@ -1031,11 +1101,11 @@ Tcl_TranslateFileName(interp, name, bufferPtr) *---------------------------------------------------------------------- */ -CONST char * -TclGetExtension(name) - CONST char *name; /* File name to parse. */ +const char * +TclGetExtension( + const char *name) /* File name to parse. */ { - CONST char *p, *lastSep; + const char *p, *lastSep; /* * First find the last directory separator. @@ -1063,7 +1133,7 @@ TclGetExtension(name) /* * In earlier versions, we used to back up to the first period in a series - * so that "foo..o" would be split into "foo" and "..o". This is a + * so that "foo..o" would be split into "foo" and "..o". This is a * confusing and usually incorrect behavior, so now we split at the last * period in the name. */ @@ -1092,16 +1162,16 @@ TclGetExtension(name) *---------------------------------------------------------------------- */ -static CONST char * -DoTildeSubst(interp, user, resultPtr) - Tcl_Interp *interp; /* Interpreter in which to store error message +static const char * +DoTildeSubst( + Tcl_Interp *interp, /* Interpreter in which to store error message * (if necessary). */ - CONST char *user; /* Name of user whose home directory should be + const char *user, /* Name of user whose home directory should be * substituted, or "" for current user. */ - Tcl_DString *resultPtr; /* Initialized DString filled with name after + Tcl_DString *resultPtr) /* Initialized DString filled with name after * tilde substitution. */ { - CONST char *dir; + const char *dir; if (*user == '\0') { Tcl_DString dirString; @@ -1109,9 +1179,10 @@ DoTildeSubst(interp, user, resultPtr) dir = TclGetEnv("HOME", &dirString); if (dir == NULL) { if (interp) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "couldn't find HOME environment ", - "variable to expand path", (char *) NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't find HOME environment " + "variable to expand path", -1)); + Tcl_SetErrorCode(interp, "TCL", "FILENAME", "NO_HOME", NULL); } return NULL; } @@ -1120,8 +1191,9 @@ DoTildeSubst(interp, user, resultPtr) } else if (TclpGetUserHome(user, resultPtr) == NULL) { if (interp) { Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist", - (char *) NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "user \"%s\" doesn't exist", user)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "USER", user, NULL); } return NULL; } @@ -1133,7 +1205,7 @@ DoTildeSubst(interp, user, resultPtr) * * Tcl_GlobObjCmd -- * - * This procedure is invoked to process the "glob" Tcl command. See the + * This procedure is invoked to process the "glob" Tcl command. See the * user documentation for details on what it does. * * Results: @@ -1147,18 +1219,19 @@ DoTildeSubst(interp, user, resultPtr) /* ARGSUSED */ int -Tcl_GlobObjCmd(dummy, interp, objc, objv) - ClientData dummy; /* Not used. */ - Tcl_Interp *interp; /* Current interpreter. */ - int objc; /* Number of arguments. */ - Tcl_Obj *CONST objv[]; /* Argument objects. */ +Tcl_GlobObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ { int index, i, globFlags, length, join, dir, result; - char *string, *separators; - Tcl_Obj *typePtr, *resultPtr, *look; + char *string; + const char *separators; + Tcl_Obj *typePtr, *look; Tcl_Obj *pathOrDir = NULL; Tcl_DString prefix; - static CONST char *options[] = { + static const char *const options[] = { "-directory", "-join", "-nocomplain", "-path", "-tails", "-types", "--", NULL }; @@ -1187,7 +1260,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) } else { /* * This clearly isn't an option; assume it's the first glob - * pattern. We must clear the error. + * pattern. We must clear the error. */ Tcl_ResetResult(interp); @@ -1203,11 +1276,14 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-directory\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } if (dir != PATH_NONE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-directory\" cannot be used with \"-path\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", + "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; } dir = PATH_DIR; @@ -1225,11 +1301,14 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-path\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } if (dir != PATH_NONE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-path\" cannot be used with \"-directory\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", + "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; } dir = PATH_GENERAL; @@ -1240,6 +1319,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-types\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); return TCL_ERROR; } typePtr = objv[i+1]; @@ -1255,14 +1335,12 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) } endOfForLoop: - if (objc - i < 1) { - Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?"); - return TCL_ERROR; - } if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) { - Tcl_AppendResult(interp, - "\"-tails\" must be used with either ", - "\"-directory\" or \"-path\"", NULL); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-tails\" must be used with either " + "\"-directory\" or \"-path\"", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", + "BADOPTIONCOMBINATION", NULL); return TCL_ERROR; } @@ -1278,8 +1356,8 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) if (dir == PATH_GENERAL) { int pathlength; - char *last; - char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength); + const char *last; + const char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength); /* * Find the last path separator in the path @@ -1305,7 +1383,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) Tcl_DStringInit(&pref); if (last == first) { /* - * The whole thing is a prefix. This means we must remove any + * The whole thing is a prefix. This means we must remove any * 'tails' flag too, since it is irrelevant now (the same * effect will happen without it), but in particular its use * in TclGlob requires a non-NULL pathOrDir. @@ -1325,7 +1403,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) /* * We must ensure that we haven't cut off too much, and turned * a valid path like '/' or 'C:/' into an incorrect path like - * '' or 'C:'. The way we do this is to add a separator if + * '' or 'C:'. The way we do this is to add a separator if * there are none presently in the prefix. */ @@ -1342,7 +1420,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) search = Tcl_DStringValue(&pref); while ((find = (strpbrk(search, "\\[]*?{}"))) != NULL) { Tcl_DStringAppend(&prefix, search, find-search); - Tcl_DStringAppend(&prefix, "\\", 1); + TclDStringAppendLiteral(&prefix, "\\"); Tcl_DStringAppend(&prefix, find, 1); search = find+1; if (*search == '\0') { @@ -1363,12 +1441,15 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) if (typePtr != NULL) { /* * The rest of the possible type arguments (except 'd') are platform - * specific. We don't complain when they are used on an incompatible + * specific. We don't complain when they are used on an incompatible * platform. */ Tcl_ListObjLength(interp, typePtr, &length); - globTypes = (Tcl_GlobTypeData*) ckalloc(sizeof(Tcl_GlobTypeData)); + if (length <= 0) { + goto skipTypes; + } + globTypes = TclStackAlloc(interp, sizeof(Tcl_GlobTypeData)); globTypes->type = 0; globTypes->perm = 0; globTypes->macType = NULL; @@ -1376,7 +1457,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) while (--length >= 0) { int len; - char *str; + const char *str; Tcl_ListObjIndex(interp, typePtr, length, &look); str = Tcl_GetStringFromObj(look, &len); @@ -1432,10 +1513,10 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) Tcl_IncrRefCount(look); } else { - Tcl_Obj* item; + Tcl_Obj *item; - if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) && - (len == 3)) { + if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) + && (len == 3)) { Tcl_ListObjIndex(interp, look, 0, &item); if (!strcmp("macintosh", Tcl_GetString(item))) { Tcl_ListObjIndex(interp, look, 1, &item); @@ -1460,15 +1541,15 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) } /* - * Error cases. We reset the 'join' flag to zero, since we + * Error cases. We reset the 'join' flag to zero, since we * haven't yet made use of it. */ badTypesArg: - TclNewObj(resultPtr); - Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1); - Tcl_AppendObjToObj(resultPtr, look); - Tcl_SetObjResult(interp, resultPtr); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad argument to \"-types\": %s", + Tcl_GetString(look))); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL); result = TCL_ERROR; join = 0; goto endOfGlob; @@ -1478,12 +1559,14 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) "only one MacOS type or creator argument" " to \"-types\" allowed", -1)); result = TCL_ERROR; + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL); join = 0; goto endOfGlob; } } } + skipTypes: /* * Now we perform the actual glob below. This may involve joining together * the pattern arguments, dealing with particular file types etc. We use a @@ -1499,8 +1582,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) Tcl_DStringInit(&prefix); } for (i = 0; i < objc; i++) { - string = Tcl_GetStringFromObj(objv[i], &length); - Tcl_DStringAppend(&prefix, string, length); + TclDStringAppendObj(&prefix, objv[i]); if (i != objc -1) { Tcl_DStringAppend(&prefix, separators, 1); } @@ -1516,11 +1598,9 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) for (i = 0; i < objc; i++) { Tcl_DStringInit(&str); if (dir == PATH_GENERAL) { - Tcl_DStringAppend(&str, Tcl_DStringValue(&prefix), - Tcl_DStringLength(&prefix)); + TclDStringAppendDString(&str, &prefix); } - string = Tcl_GetStringFromObj(objv[i], &length); - Tcl_DStringAppend(&str, string, length); + TclDStringAppendObj(&str, objv[i]); if (TclGlob(interp, Tcl_DStringValue(&str), pathOrDir, globFlags, globTypes) != TCL_OK) { result = TCL_ERROR; @@ -1544,7 +1624,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) if (Tcl_ListObjLength(interp, Tcl_GetObjResult(interp), &length) != TCL_OK) { /* - * This should never happen. Maybe we should be more dramatic. + * This should never happen. Maybe we should be more dramatic. */ result = TCL_ERROR; @@ -1552,20 +1632,25 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) } if (length == 0) { - Tcl_AppendResult(interp, "no files matched glob pattern", - (join || (objc == 1)) ? " \"" : "s \"", (char *) NULL); + Tcl_Obj *errorMsg = + Tcl_ObjPrintf("no files matched glob pattern%s \"", + (join || (objc == 1)) ? "" : "s"); + if (join) { - Tcl_AppendResult(interp, Tcl_DStringValue(&prefix), - (char *) NULL); + Tcl_AppendToObj(errorMsg, Tcl_DStringValue(&prefix), -1); } else { - char *sep = ""; + const char *sep = ""; + for (i = 0; i < objc; i++) { - string = Tcl_GetString(objv[i]); - Tcl_AppendResult(interp, sep, string, (char *) NULL); + Tcl_AppendPrintfToObj(errorMsg, "%s%s", + sep, Tcl_GetString(objv[i])); sep = " "; } } - Tcl_AppendResult(interp, "\"", (char *) NULL); + Tcl_AppendToObj(errorMsg, "\"", -1); + Tcl_SetObjResult(interp, errorMsg); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "NOMATCH", + NULL); result = TCL_ERROR; } } @@ -1584,7 +1669,7 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) if (globTypes->macCreator != NULL) { Tcl_DecrRefCount(globTypes->macCreator); } - ckfree((char *) globTypes); + TclStackFree(interp, globTypes); } return result; } @@ -1594,13 +1679,13 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) * * TclGlob -- * - * This procedure prepares arguments for the DoGlob call. It sets the + * This procedure prepares arguments for the DoGlob call. It sets the * separator string based on the platform, performs * tilde substitution, * and calls DoGlob. * * The interpreter's result, on entry to this function, must be a valid * Tcl list (e.g. it could be empty), since we will lappend any new - * results to that list. If it is not a valid list, this function will + * results to that list. If it is not a valid list, this function will * fail to do anything very meaningful. * * Note that if globFlags contains 'TCL_GLOBMODE_TAILS' then pathPrefix @@ -1608,12 +1693,10 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) * * Results: * The return value is a standard Tcl result indicating whether an error - * occurred in globbing. After a normal return the result in interp (set + * occurred in globbing. After a normal return the result in interp (set * by DoGlob) holds all of the file names given by the pattern and - * pathPrefix arguments. After an error the result in interp will hold - * an error message, unless the 'TCL_GLOBMODE_NO_COMPLAIN' flag was - * given, in which case an error results in a TCL_OK return leaving the - * interpreter's result unmodified. + * pathPrefix arguments. After an error the result in interp will hold + * an error message. * * Side effects: * The 'pattern' is written to. @@ -1623,19 +1706,19 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv) /* ARGSUSED */ int -TclGlob(interp, pattern, pathPrefix, globFlags, types) - Tcl_Interp *interp; /* Interpreter for returning error message or +TclGlob( + Tcl_Interp *interp, /* Interpreter for returning error message or * appending list of matching file names. */ - char *pattern; /* Glob pattern to match. Must not refer to a + char *pattern, /* Glob pattern to match. Must not refer to a * static string. */ - Tcl_Obj *pathPrefix; /* Path prefix to glob pattern, if non-null, + Tcl_Obj *pathPrefix, /* Path prefix to glob pattern, if non-null, * which is considered literally. */ - int globFlags; /* Stores or'ed combination of flags */ - Tcl_GlobTypeData *types; /* Struct containing acceptable types. May be + int globFlags, /* Stores or'ed combination of flags */ + Tcl_GlobTypeData *types) /* Struct containing acceptable types. May be * NULL. */ { - char *separators; - CONST char *head; + const char *separators; + const char *head; char *tail, *start; int result; Tcl_Obj *filenamesObj, *savedResultObj; @@ -1682,28 +1765,15 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) c = *tail; *tail = '\0'; - if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) { - /* - * We will ignore any error message here, and we don't want to - * mess up the interpreter's result. - */ - head = DoTildeSubst(NULL, start+1, &buffer); - } else { - head = DoTildeSubst(interp, start+1, &buffer); - } + head = DoTildeSubst(interp, start+1, &buffer); *tail = c; if (head == NULL) { - if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) { - return TCL_OK; - } else { - return TCL_ERROR; - } + return TCL_ERROR; } if (head != Tcl_DStringValue(&buffer)) { Tcl_DStringAppend(&buffer, head, -1); } - pathPrefix = Tcl_NewStringObj(Tcl_DStringValue(&buffer), - Tcl_DStringLength(&buffer)); + pathPrefix = TclDStringToObj(&buffer); Tcl_IncrRefCount(pathPrefix); globFlags |= TCL_GLOBMODE_DIR; if (c != '\0') { @@ -1721,7 +1791,7 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) /* * Handling empty path prefixes with glob patterns like 'C:' or * 'c:////////' is a pain on Windows if we leave it too late, since these - * aren't really patterns at all! We therefore check the head of the + * aren't really patterns at all! We therefore check the head of the * pattern now for such cases, if we don't have an unquoted prefix yet. * * Similarly on Unix with '/' at the head of the pattern -- it just @@ -1764,28 +1834,24 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) case TCL_PATH_VOLUME_RELATIVE: { /* * Volume relative path which is equivalent to a path in the - * root of the cwd's volume. We will actually return + * root of the cwd's volume. We will actually return * non-volume-relative paths here. i.e. 'glob /foo*' will - * return 'C:/foobar'. This is much the same as globbing for - * a path with '\\' will return one with '/' on Windows. + * return 'C:/foobar'. This is much the same as globbing for a + * path with '\\' will return one with '/' on Windows. */ Tcl_Obj *cwd = Tcl_FSGetCwd(interp); if (cwd == NULL) { Tcl_DecrRefCount(temp); - if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) { - return TCL_OK; - } else { - return TCL_ERROR; - } + return TCL_ERROR; } pathPrefix = Tcl_NewStringObj(Tcl_GetString(cwd), 3); Tcl_DecrRefCount(cwd); if (tail[0] == '/') { tail++; } else { - tail+=2; + tail += 2; } Tcl_IncrRefCount(pathPrefix); break; @@ -1847,6 +1913,7 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) Tcl_IncrRefCount(savedResultObj); Tcl_ResetResult(interp); TclNewObj(filenamesObj); + Tcl_IncrRefCount(filenamesObj); /* * Now we do the actual globbing, adding filenames as we go to buffer in @@ -1855,10 +1922,32 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) if (*tail == '\0' && pathPrefix != NULL) { /* - * An empty pattern + * An empty pattern. This means 'pathPrefix' is actually a full path + * of a file/directory we want to simply check for existence and type. */ - result = Tcl_FSMatchInDirectory(interp, filenamesObj, pathPrefix, - NULL, types); + + if (types == NULL) { + /* + * We just want to check for existence. In this case we make it + * easy on Tcl_FSMatchInDirectory and its sub-implementations by + * not bothering them (even though they should support this + * situation) and we just use the simple existence check with + * Tcl_FSAccess. + */ + + if (Tcl_FSAccess(pathPrefix, F_OK) == 0) { + Tcl_ListObjAppendElement(interp, filenamesObj, pathPrefix); + } + result = TCL_OK; + } else { + /* + * We want to check for the correct type. Tcl_FSMatchInDirectory + * is documented to do this for us, if we give it a NULL pattern. + */ + + result = Tcl_FSMatchInDirectory(interp, filenamesObj, pathPrefix, + NULL, types); + } } else { result = DoGlob(interp, filenamesObj, separators, pathPrefix, globFlags & TCL_GLOBMODE_DIR, tail, types); @@ -1870,21 +1959,19 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) if (result != TCL_OK) { TclDecrRefCount(filenamesObj); - if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) { - /* Put back the old result and reset the return code */ - Tcl_SetObjResult(interp, savedResultObj); - result = TCL_OK; - } TclDecrRefCount(savedResultObj); + if (pathPrefix != NULL) { + Tcl_DecrRefCount(pathPrefix); + } return result; } /* - * If we only want the tails, we must strip off the prefix now. It may + * If we only want the tails, we must strip off the prefix now. It may * seem more efficient to pass the tails flag down into DoGlob, * Tcl_FSMatchInDirectory, but those functions are continually adjusting * the prefix as the various pieces of the pattern are assimilated, so - * that would add a lot of complexity to the code. This way is a little + * that would add a lot of complexity to the code. This way is a little * slower (when the -tails flag is given), but much simpler to code. * * We do it by rewriting the result list in-place. @@ -1894,12 +1981,17 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) int objc, i; Tcl_Obj **objv; int prefixLen; + const char *pre; /* * If this length has never been set, set it here. */ - CONST char *pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen); + if (pathPrefix == NULL) { + Tcl_Panic("Called TclGlob with TCL_GLOBMODE_TAILS and pathPrefix==NULL"); + } + + pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen); if (prefixLen > 0 && (strchr(separators, pre[prefixLen-1]) == NULL)) { /* @@ -1917,20 +2009,20 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv); for (i = 0; i< objc; i++) { int len; - char *oldStr = Tcl_GetStringFromObj(objv[i], &len); - Tcl_Obj* elems[1]; + const char *oldStr = Tcl_GetStringFromObj(objv[i], &len); + Tcl_Obj *elem; if (len == prefixLen) { if ((pattern[0] == '\0') || (strchr(separators, pattern[0]) == NULL)) { - elems[0] = Tcl_NewStringObj(".", 1); + TclNewLiteralStringObj(elem, "."); } else { - elems[0] = Tcl_NewStringObj("/", 1); + TclNewLiteralStringObj(elem, "/"); } } else { - elems[0] = Tcl_NewStringObj(oldStr+prefixLen, len-prefixLen); + elem = Tcl_NewStringObj(oldStr+prefixLen, len-prefixLen); } - Tcl_ListObjReplace(interp, filenamesObj, i, 1, 1, elems); + Tcl_ListObjReplace(interp, filenamesObj, i, 1, 1, &elem); } } @@ -1952,6 +2044,9 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) } TclDecrRefCount(savedResultObj); TclDecrRefCount(filenamesObj); + if (pathPrefix != NULL) { + Tcl_DecrRefCount(pathPrefix); + } return result; } @@ -1966,7 +2061,7 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) * * Results: * Updates stringPtr to point to the matching character, or to the end of - * the string if nothing matched. The return value is 1 if a match was + * the string if nothing matched. The return value is 1 if a match was * found at the top level, otherwise it is 0. * * Side effects: @@ -1976,9 +2071,9 @@ TclGlob(interp, pattern, pathPrefix, globFlags, types) */ static int -SkipToChar(stringPtr, match) - char **stringPtr; /* Pointer string to check. */ - int match; /* Character to find. */ +SkipToChar( + char **stringPtr, /* Pointer string to check. */ + int match) /* Character to find. */ { int quoted, level; register char *p; @@ -2023,9 +2118,9 @@ SkipToChar(stringPtr, match) * * Results: * The return value is a standard Tcl result indicating whether an error - * occurred in globbing. After a normal return the result in interp will + * occurred in globbing. After a normal return the result in interp will * be set to hold all of the file names given by the dir and remaining - * arguments. After an error the result in interp will hold an error + * arguments. After an error the result in interp will hold an error * message. * * Side effects: @@ -2035,21 +2130,21 @@ SkipToChar(stringPtr, match) */ static int -DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) - Tcl_Interp *interp; /* Interpreter to use for error reporting +DoGlob( + Tcl_Interp *interp, /* Interpreter to use for error reporting * (e.g. unmatched brace). */ - Tcl_Obj *matchesObj; /* Unshared list object in which to place all + Tcl_Obj *matchesObj, /* Unshared list object in which to place all * resulting filenames. Caller allocates and * deallocates; DoGlob must not touch the * refCount of this object. */ - char *separators; /* String containing separator characters that + const char *separators, /* String containing separator characters that * should be used to identify globbing * boundaries. */ - Tcl_Obj *pathPtr; /* Completely expanded prefix. */ - int flags; /* If non-zero then pathPtr is a directory */ - char *pattern; /* The pattern to match against. Must not be - * a pointer to a static string. */ - Tcl_GlobTypeData *types; /* List object containing list of acceptable + Tcl_Obj *pathPtr, /* Completely expanded prefix. */ + int flags, /* If non-zero then pathPtr is a directory */ + char *pattern, /* The pattern to match against. Must not be a + * pointer to a static string. */ + Tcl_GlobTypeData *types) /* List object containing list of acceptable * types. May be NULL. */ { int baseLength, quoted, count; @@ -2068,8 +2163,8 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) if (*pattern == '\\') { /* * If the first character is escaped, either we have a directory - * separator, or we have any other character. In the latter case - * the rest is a pattern, and we must break from the loop. This + * separator, or we have any other character. In the latter case + * the rest is a pattern, and we must break from the loop. This * is particularly important on Windows where '\' is both the * escaping character and a directory separator. */ @@ -2086,67 +2181,6 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) } /* - * This block of code is not exercised by the Tcl test suite as of Tcl - * 8.5a0. Simplifications to the calling paths suggest it may not be - * necessary any more, since path separators are handled elsewhere. It is - * left in place in case new bugs are reported - */ - -#if 0 /* PROBABLY_OBSOLETE */ - /* - * Deal with path separators. - */ - - if (pathPtr == NULL) { - /* - * Length used to be the length of the prefix, and lastChar the - * lastChar of the prefix. But, none of this is used any more. - */ - - int length = 0; - char lastChar = 0; - - switch (tclPlatform) { - case TCL_PLATFORM_WINDOWS: - /* - * If this is a drive relative path, add the colon and the - * trailing slash if needed. Otherwise add the slash if this is - * the first absolute element, or a later relative element. Add - * an extra slash if this is a UNC path. - */ - - if (*name == ':') { - Tcl_DStringAppend(&append, ":", 1); - if (count > 1) { - Tcl_DStringAppend(&append, "/", 1); - } - } else if ((*pattern != '\0') && (((length > 0) - && (strchr(separators, lastChar) == NULL)) - || ((length == 0) && (count > 0)))) { - Tcl_DStringAppend(&append, "/", 1); - if ((length == 0) && (count > 1)) { - Tcl_DStringAppend(&append, "/", 1); - } - } - - break; - case TCL_PLATFORM_UNIX: - /* - * Add a separator if this is the first absolute element, or a - * later relative element. - */ - - if ((*pattern != '\0') && (((length > 0) - && (strchr(separators, lastChar) == NULL)) - || ((length == 0) && (count > 0)))) { - Tcl_DStringAppend(&append, "/", 1); - } - break; - } - } -#endif /* PROBABLY_OBSOLETE */ - - /* * Look for the first matching pair of braces or the first directory * separator that is not inside a pair of braces. */ @@ -2183,13 +2217,17 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) closeBrace = p; break; } - Tcl_SetResult(interp, "unmatched open-brace in file name", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unmatched open-brace in file name", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE", + NULL); return TCL_ERROR; } else if (*p == '}') { - Tcl_SetResult(interp, "unmatched close-brace in file name", - TCL_STATIC); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unmatched close-brace in file name", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE", + NULL); return TCL_ERROR; } } @@ -2200,8 +2238,8 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) if (openBrace != NULL) { char *element; - Tcl_DString newName; + Tcl_DStringInit(&newName); /* @@ -2250,12 +2288,13 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) */ if (*p != '\0') { + char savedChar = *p; + /* * Note that we are modifying the string in place. This won't work if * the string is a static. */ - char savedChar = *p; *p = '\0'; firstSpecialChar = strpbrk(pattern, "*[]?\\"); *p = savedChar; @@ -2274,7 +2313,7 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) TCL_GLOB_TYPE_DIR, 0, NULL, NULL }; char save = *p; - Tcl_Obj* subdirsPtr; + Tcl_Obj *subdirsPtr; if (*p == '\0') { return Tcl_FSMatchInDirectory(interp, matchesObj, pathPtr, @@ -2288,18 +2327,48 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) *p = '\0'; TclNewObj(subdirsPtr); + Tcl_IncrRefCount(subdirsPtr); result = Tcl_FSMatchInDirectory(interp, subdirsPtr, pathPtr, pattern, &dirOnly); *p = save; if (result == TCL_OK) { - int subdirc, i; + int subdirc, i, repair = -1; Tcl_Obj **subdirv; result = Tcl_ListObjGetElements(interp, subdirsPtr, &subdirc, &subdirv); for (i=0; result==TCL_OK && i<subdirc; i++) { + Tcl_Obj *copy = NULL; + + if (pathPtr == NULL && Tcl_GetString(subdirv[i])[0] == '~') { + Tcl_ListObjLength(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], 1, p+1, types); + if (copy) { + int end; + + Tcl_DecrRefCount(subdirv[i]); + subdirv[i] = copy; + Tcl_ListObjLength(NULL, matchesObj, &end); + while (repair < end) { + const char *bytes; + int numBytes; + Tcl_Obj *fixme, *newObj; + + Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme); + bytes = Tcl_GetStringFromObj(fixme, &numBytes); + newObj = Tcl_NewStringObj(bytes+2, numBytes-2); + Tcl_ListObjReplace(NULL, matchesObj, repair, 1, + 1, &newObj); + repair++; + } + repair = -1; + } } } TclDecrRefCount(subdirsPtr); @@ -2311,6 +2380,9 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) */ if (*p == '\0') { + int length; + Tcl_DString append; + /* * This is the code path reached by a command like 'glob foo'. * @@ -2323,9 +2395,6 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) * approach). */ - int length; - Tcl_DString append; - Tcl_DStringInit(&append); Tcl_DStringAppend(&append, pattern, p-pattern); @@ -2340,30 +2409,20 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) if (length == 0 && (Tcl_DStringLength(&append) == 0)) { if (((*name == '\\') && (name[1] == '/' || name[1] == '\\')) || (*name == '/')) { - Tcl_DStringAppend(&append, "/", 1); + TclDStringAppendLiteral(&append, "/"); } else { - Tcl_DStringAppend(&append, ".", 1); + TclDStringAppendLiteral(&append, "."); } } -#if defined(__CYGWIN__) && defined(__WIN32__) - { - extern int cygwin_conv_to_win32_path(CONST char *, char *); - char winbuf[MAX_PATH+1]; - - cygwin_conv_to_win32_path(Tcl_DStringValue(&append), winbuf); - Tcl_DStringFree(&append); - Tcl_DStringAppend(&append, winbuf, -1); - } -#endif /* __CYGWIN__ && __WIN32__ */ break; case TCL_PLATFORM_UNIX: if (length == 0 && (Tcl_DStringLength(&append) == 0)) { if ((*name == '\\' && name[1] == '/') || (*name == '/')) { - Tcl_DStringAppend(&append, "/", 1); + TclDStringAppendLiteral(&append, "/"); } else { - Tcl_DStringAppend(&append, ".", 1); + TclDStringAppendLiteral(&append, "."); } } break; @@ -2374,8 +2433,7 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) */ if (pathPtr == NULL) { - joinedPtr = Tcl_NewStringObj(Tcl_DStringValue(&append), - Tcl_DStringLength(&append)); + joinedPtr = TclDStringToObj(&append); } else if (flags) { joinedPtr = TclNewFSPathObj(pathPtr, Tcl_DStringValue(&append), Tcl_DStringLength(&append)); @@ -2387,7 +2445,7 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) */ int len; - CONST char *joined = Tcl_GetStringFromObj(joinedPtr,&len); + const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); if (strchr(separators, joined[len-1]) == NULL) { Tcl_AppendToObj(joinedPtr, "/", 1); @@ -2398,9 +2456,10 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) } Tcl_IncrRefCount(joinedPtr); Tcl_DStringFree(&append); - Tcl_FSMatchInDirectory(interp, matchesObj, joinedPtr, NULL, types); + result = Tcl_FSMatchInDirectory(interp, matchesObj, joinedPtr, NULL, + types); Tcl_DecrRefCount(joinedPtr); - return TCL_OK; + return result; } /* @@ -2416,14 +2475,14 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) if (strchr(separators, pattern[0]) == NULL) { /* * The current prefix must end in a separator, unless this is a - * volume-relative path. In particular globbing in Windows - * shares, when not using -dir or -path, e.g. 'glob [file join + * volume-relative path. In particular globbing in Windows shares, + * when not using -dir or -path, e.g. 'glob [file join * //machine/share/subdir *]' requires adding a separator here. * This behaviour is not currently tested for in the test suite. */ int len; - CONST char *joined = Tcl_GetStringFromObj(joinedPtr,&len); + const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); if (strchr(separators, joined[len-1]) == NULL) { if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) { @@ -2446,7 +2505,7 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) * * Tcl_AllocStatBuf -- * - * This procedure allocates a Tcl_StatBuf on the heap. It exists so that + * This procedure allocates a Tcl_StatBuf on the heap. It exists so that * extensions may be used unchanged on systems where largefile support is * optional. * @@ -2461,8 +2520,132 @@ DoGlob(interp, matchesObj, separators, pathPtr, flags, pattern, types) */ Tcl_StatBuf * -Tcl_AllocStatBuf() { - return (Tcl_StatBuf *) ckalloc(sizeof(Tcl_StatBuf)); +Tcl_AllocStatBuf(void) +{ + return ckalloc(sizeof(Tcl_StatBuf)); +} + +/* + *--------------------------------------------------------------------------- + * + * Access functions for Tcl_StatBuf -- + * + * These functions provide portable read-only access to the portable + * fields of the Tcl_StatBuf structure (really a 'struct stat', 'struct + * stat64' or something else related). [TIP #316] + * + * Results: + * The value from the field being retrieved. + * + * Side effects: + * None. + * + *--------------------------------------------------------------------------- + */ + +unsigned +Tcl_GetFSDeviceFromStat( + const Tcl_StatBuf *statPtr) +{ + return (unsigned) statPtr->st_dev; +} + +unsigned +Tcl_GetFSInodeFromStat( + const Tcl_StatBuf *statPtr) +{ + return (unsigned) statPtr->st_ino; +} + +unsigned +Tcl_GetModeFromStat( + const Tcl_StatBuf *statPtr) +{ + return (unsigned) statPtr->st_mode; +} + +int +Tcl_GetLinkCountFromStat( + const Tcl_StatBuf *statPtr) +{ + return (int)statPtr->st_nlink; +} + +int +Tcl_GetUserIdFromStat( + const Tcl_StatBuf *statPtr) +{ + return (int) statPtr->st_uid; +} + +int +Tcl_GetGroupIdFromStat( + const Tcl_StatBuf *statPtr) +{ + return (int) statPtr->st_gid; +} + +int +Tcl_GetDeviceTypeFromStat( + const Tcl_StatBuf *statPtr) +{ + return (int) statPtr->st_rdev; +} + +Tcl_WideInt +Tcl_GetAccessTimeFromStat( + const Tcl_StatBuf *statPtr) +{ + return (Tcl_WideInt) statPtr->st_atime; +} + +Tcl_WideInt +Tcl_GetModificationTimeFromStat( + const Tcl_StatBuf *statPtr) +{ + return (Tcl_WideInt) statPtr->st_mtime; +} + +Tcl_WideInt +Tcl_GetChangeTimeFromStat( + const Tcl_StatBuf *statPtr) +{ + return (Tcl_WideInt) statPtr->st_ctime; +} + +Tcl_WideUInt +Tcl_GetSizeFromStat( + const Tcl_StatBuf *statPtr) +{ + return (Tcl_WideUInt) statPtr->st_size; +} + +Tcl_WideUInt +Tcl_GetBlocksFromStat( + const Tcl_StatBuf *statPtr) +{ +#ifdef HAVE_STRUCT_STAT_ST_BLOCKS + return (Tcl_WideUInt) statPtr->st_blocks; +#else + register unsigned blksize = Tcl_GetBlockSizeFromStat(statPtr); + + return ((Tcl_WideUInt) statPtr->st_size + blksize - 1) / blksize; +#endif +} + +unsigned +Tcl_GetBlockSizeFromStat( + const Tcl_StatBuf *statPtr) +{ +#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE + return (unsigned) statPtr->st_blksize; +#else + /* + * Not a great guess, but will do... + */ + + return GUESSED_BLOCK_SIZE; +#endif } /* |