Tcl Source Code

2012-08-07  Don Porter  <[email protected]>

	* generic/tclIOUtil.c:	[Bug 3554250] Overlooked one field of
	cleanup in the thread exit handler for the filesystem subsystem.

2012-07-31  Jan Nijtmans  <[email protected]>

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(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);

/*
 *----------------------------------------------------------------------
 *

	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];

	    /*
	     * Skip separators.
	     */

	    while (*tail && (tail[0] == '/' || tail[0] == '\\')) {
		tail++;

    Tcl_Obj *pathPtr,		/* Native path of interest */
    int *driveNameLengthPtr,	/* Returns length of drive, if non-NULL and
				 * path was absolute */
    Tcl_Obj **driveNameRef)
{
    Tcl_PathType type = TCL_PATH_ABSOLUTE;
    int pathLen;
    char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);

    if (path[0] == '~') {
	/*
	 * This case is common to all platforms. Paths that begin with ~ are
	 * absolute.
	 */

	if (driveNameLengthPtr != NULL) {
	    char *end = path + 1;
	    while ((*end != '\0') && (*end != '/')) {
		end++;
	    }
	    *driveNameLengthPtr = end - path;
	}
    } else {
	switch (tclPlatform) {
	case TCL_PLATFORM_UNIX: {
	    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;
		}






	    }



#endif
	    if (path[0] == '/') {
#ifdef __CYGWIN__
		/*
		 * Check for Cygwin // network path prefix
		 */
		if (path[1] == '/') {
		    path++;
		}
#endif
		if (driveNameLengthPtr != NULL) {
		    /*
		     * We need this addition in case the QNX or Cygwin code was used.
		     */

		    *driveNameLengthPtr = (1 + path - origPath);
		}
	    } else {
		type = TCL_PATH_RELATIVE;
	    }
	    break;
	}
	case TCL_PLATFORM_WINDOWS: {

				 * number of elements in the path. */
    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 *tmpPtr, *eltPtr;
    int i, size, len;
    char *p, *str;


    /*
     * Perform the splitting, using objectified, vfs-aware code.
     */

    tmpPtr = Tcl_NewStringObj(path, -1);
    Tcl_IncrRefCount(tmpPtr);

 */

static Tcl_Obj *
SplitUnixPath(
    const char *path)		/* Pointer to string containing a path. */
{
    int length;
    const char *p, *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;
	}






    }



#endif

    p = path;
    if (*p == '/') {
	Tcl_Obj *rootElt = Tcl_NewStringObj("/", 1);
	p++;
#ifdef __CYGWIN__
	/*
	 * Check for Cygwin // network path prefix
	 */

	if (*p == '/') {
	    Tcl_AppendToObj(rootElt, "/", 1);
	    p++;
	}
#endif
	Tcl_ListObjAppendElement(NULL, result, rootElt);
    }

    /*
     * 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++;
	}
	length = p - elementStart;
	if (length > 0) {
	    Tcl_Obj *nextElt;
	    if ((elementStart[0] == '~') && (elementStart != path)) {
		TclNewLiteralStringObj(nextElt, "./");
		Tcl_AppendToObj(nextElt, elementStart, length);
	    } else {
		nextElt = Tcl_NewStringObj(elementStart, length);
	    }
	    Tcl_ListObjAppendElement(NULL, result, nextElt);
	}
	if (*p++ == '\0') {
	    break;
	}
    }
    return result;
}

/*

void
TclpNativeJoinPath(
    Tcl_Obj *prefix,
    const char *joining)
{
    int length, needsSep;

    const char *p;
    char *dest, *start;

    start = Tcl_GetStringFromObj(prefix, &length);

    /*
     * Remove the ./ from tilde prefixed elements, and drive-letter prefixed
     * elements on Windows, unless it is the first component.
     */

    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;

    /*
     * Build the list of paths.
     */

    for (i = 0; i < argc; i++) {
	Tcl_ListObjAppendElement(NULL, listObj,

    case TCL_PLATFORM_WINDOWS:
	separators = "/\\:";
	break;
    }

    if (dir == PATH_GENERAL) {
	int pathlength;
	char *last;
	char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength);

	/*
	 * Find the last path separator in the path
	 */

	last = first + pathlength;
	for (; last != first; last--) {

	globTypes->type = 0;
	globTypes->perm = 0;
	globTypes->macType = NULL;
	globTypes->macCreator = NULL;

	while (--length >= 0) {
	    int len;
	    char *str;

	    Tcl_ListObjIndex(interp, typePtr, length, &look);
	    str = Tcl_GetStringFromObj(look, &len);
	    if (strcmp("readonly", str) == 0) {
		globTypes->perm |= TCL_GLOB_PERM_RONLY;
	    } else if (strcmp("hidden", str) == 0) {
		globTypes->perm |= TCL_GLOB_PERM_HIDDEN;

		if (globTypes->macType != NULL) {
		    goto badMacTypesArg;
		}
		globTypes->macType = look;
		Tcl_IncrRefCount(look);

	    } else {
		Tcl_Obj* item;

		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);
			if (!strcmp("type", Tcl_GetString(item))) {
			    Tcl_ListObjIndex(interp, look, 2, &item);
			    if (globTypes->macType != NULL) {
				goto badMacTypesArg;

		    return TCL_ERROR;
		}
		pathPrefix = Tcl_NewStringObj(Tcl_GetString(cwd), 3);
		Tcl_DecrRefCount(cwd);
		if (tail[0] == '/') {
		    tail++;
		} else {
		    tail+=2;
		}
		Tcl_IncrRefCount(pathPrefix);
		break;
	    }
	    case TCL_PATH_ABSOLUTE:
		/*
		 * Absolute, possibly network path //Machine/Share. Use that

    /*
     * Now we do the actual globbing, adding filenames as we go to buffer in
     * filenamesObj
     */

    if (*tail == '\0' && pathPrefix != NULL) {
	/*
	 * An empty pattern.  This means 'pathPrefix' is actually
	 * a full path of a file/directory we want to simply check
	 * for existence and type.
	 */

	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);
    }

		prefixLen++;
	    }
	}

	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];

	    if (len == prefixLen) {
		if ((pattern[0] == '\0')
			|| (strchr(separators, pattern[0]) == NULL)) {
		    TclNewLiteralStringObj(elems[0], ".");
		} else {
		    TclNewLiteralStringObj(elems[0], "/");
		}
	    } else {
		elems[0] = Tcl_NewStringObj(oldStr+prefixLen, len-prefixLen);
	    }
	    Tcl_ListObjReplace(interp, filenamesObj, i, 1, 1, elems);
	}
    }

    /*
     * Now we have a list of discovered filenames in filenamesObj and a list
     * of previously discovered (saved earlier from the interpreter result) in
     * savedResultObj. Merge them and put them back in the interpreter result.

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
				 * resulting filenames. Caller allocates and
				 * deallocates; DoGlob must not touch the
				 * refCount of this object. */
    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

	    }
	} else if (strchr(separators, *pattern) == NULL) {
	    break;
	}
	count++;
    }

    /*
     * 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.
     */

    openBrace = closeBrace = NULL;
    quoted = 0;

    /*
     * Substitute the alternate patterns from the braces and recurse.
     */

    if (openBrace != NULL) {
	char *element;

	Tcl_DString newName;

	Tcl_DStringInit(&newName);

	/*
	 * For each element within in the outermost pair of braces, append the
	 * element and the remainder to the fixed portion before the first
	 * brace and recursively call DoGlob.
	 */

     * Alternatively, if there are no globbing characters then again there are
     * two cases. If we're at the end of the string, we just need to check for
     * the given path's existence and type. If we're not at the end of the
     * string, we recurse.
     */

    if (*p != '\0') {


	/*
	 * 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;
    } else {
	firstSpecialChar = strpbrk(pattern, "*[]?\\");
    }

    if (firstSpecialChar != NULL) {
	/*
	 * Look for matching files in the given directory. The implementation
	 * of this function is filesystem specific. For each file that
	 * matches, it will add the match onto the resultPtr given.
	 */

	static Tcl_GlobTypeData dirOnly = {
	    TCL_GLOB_TYPE_DIR, 0, NULL, NULL
	};
	char save = *p;
	Tcl_Obj* subdirsPtr;

	if (*p == '\0') {
	    return Tcl_FSMatchInDirectory(interp, matchesObj, pathPtr,
		    pattern, types);
	}

	/*

		    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);
	return result;
    }

    /*
     * We reach here with no pattern char in current section
     */

    if (*p == '\0') {



	/*
	 * This is the code path reached by a command like 'glob foo'.
	 *
	 * There are no more wildcards in the pattern and no more unprocessed
	 * characters in the pattern, so now we can construct the path, and
	 * pass it to Tcl_FSMatchInDirectory with an empty pattern to verify
	 * the existence of the file and check it is of the correct type (if a
	 * 'types' flag it given -- if no such flag was given, we could just
	 * use 'Tcl_FSLStat', but for simplicity we keep to a common
	 * approach).
	 */

	int length;
	Tcl_DString append;

	Tcl_DStringInit(&append);
	Tcl_DStringAppend(&append, pattern, p-pattern);

	if (pathPtr != NULL) {
	    (void) Tcl_GetStringFromObj(pathPtr, &length);
	} else {
	    length = 0;

test filename-4.12 {Tcl_SplitPath: unix} {testsetplatform} {
    testsetplatform unix
    file split ../..
} {.. ..}
test filename-4.13 {Tcl_SplitPath: unix} {testsetplatform} {
    testsetplatform unix
    file split //foo
} "[file split //] foo"
test filename-4.14 {Tcl_SplitPath: unix} {testsetplatform} {
    testsetplatform unix
    file split foo//bar
} {foo bar}
test filename-4.15 {Tcl_SplitPath: unix} {testsetplatform} {
    testsetplatform unix
    file split ~foo

test filename-7.16 {Tcl_JoinPath: unix} {testsetplatform} {
    testsetplatform unix
    file join a . ./~b
} {a/./~b}
test filename-7.17 {Tcl_JoinPath: unix} {testsetplatform} {
    testsetplatform unix
    file join //a b
} "[file split //]a/b"
test filename-7.18 {Tcl_JoinPath: unix} {testsetplatform} {
    testsetplatform unix
    file join /// a b
} "[file split //]a/b"


test filename-9.1 {Tcl_JoinPath: win} {testsetplatform} {
    testsetplatform win
    file join a b
} {a/b}
test filename-9.2 {Tcl_JoinPath: win} {testsetplatform} {