Tcl Source Code

 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[], int normalize);

Tcl_Obj *
Tcl_FSJoinPath(
    Tcl_Obj *listObj,		/* Path elements to join, may have a zero
				 * reference count. */
    int elements)		/* Number of elements to use (-1 = all) */
{
    Tcl_Obj *res;
    int objc;
    Tcl_Obj **objv;

    if (Tcl_ListObjLength(NULL, listObj, &objc) != TCL_OK) {
	return NULL;
    }

    elements = ((elements >= 0) && (elements <= objc)) ? elements : objc;

    Tcl_ListObjGetElements(NULL, listObj, &objc, &objv);
    res = TclJoinPath(elements, objv, 0);

    return res;
}

Tcl_Obj *
TclJoinPath(
    int elements,		/* Number of elements to use (-1 = all) */
    Tcl_Obj * const objv[],	/* Path elements to join */
    int normalize)		/* 1 if special normalization case (force second
				 * path relative) */
{
    Tcl_Obj *res = NULL;	/* Resulting path object (container of join) */
    Tcl_Obj *elt;		/* Path part (result if returns part of path) */
    int i;
    Tcl_Filesystem *fsPtr = NULL;

    for (i = 0; i < elements; i++) {

	 * use the special case when we have exactly two elements, but we
	 * could expand that in the future.
         *
         * Bugfix [a47641a0]. TclNewFSPathObj requires first argument
         * to be an absolute path. Added a check for that elt is absolute.
	 */

	if ((i == 0) && (elements == 2)
                && (elt->typePtr == &tclFsPathType)
		&& !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))
                && TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) {
            Tcl_Obj *tailObj = objv[i+1];

	    type = normalize ? TCL_PATH_RELATIVE :
		    TclGetPathType(tailObj, NULL, NULL, NULL);
	    if (type == TCL_PATH_RELATIVE) {
		const char *str;
		int len;

		str = Tcl_GetStringFromObj(tailObj, &len);
		if (len == 0) {
		    /*

			goto partReturn; /* return elt; */
		    }
		}
	    }
	}
	strElt = Tcl_GetStringFromObj(elt, &strEltLen);
	driveNameLength = 0;
	type = (normalize && (i > 0)) ? TCL_PATH_RELATIVE :
		TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName);
	if (type != TCL_PATH_RELATIVE) {
	    /*
	     * Zero out the current result.
	     */

	    if (res != NULL) {
		TclDecrRefCount(res);

    name = Tcl_GetStringFromObj(pathPtr, &len);

    /*
     * Handle tilde substitutions, if needed.
     */

    if (len && name[0] == '~') {
	char *expandedUser;
	Tcl_DString temp;
	int split;
	char separator = '/';



	/*
	 * We have multiple cases '~/foo/bar...', '~user/foo/bar...', etc.
	 * split becomes value 1 for '~/...' as well as for '~'.
	 */
	split = FindSplitPos(name, separator);



	/*
	 * Do some tilde substitution.
	 */

	if (split == 1) {
	    /*
	     * We have just '~' (or '~/...')
	     */

	    const char *dir;
	    Tcl_DString dirString;





	    dir = TclGetEnv("HOME", &dirString);
	    if (dir == NULL) {
		if (interp) {
		    Tcl_ResetResult(interp);
		    Tcl_AppendResult(interp, "couldn't find HOME environment "
			    "variable to expand path", NULL);
		}
		return TCL_ERROR;
	    }
	    Tcl_DStringInit(&temp);
	    Tcl_JoinPath(1, &dir, &temp);
	    Tcl_DStringFree(&dirString);
	} else {
	    /*
	     * We have a user name '~user'
	     */

	    Tcl_DString userName;

	    Tcl_DStringInit(&userName);
	    Tcl_DStringAppend(&userName, name+1, split-1);
	    expandedUser = Tcl_DStringValue(&userName);

	    Tcl_DStringInit(&temp);
	    if (TclpGetUserHome(expandedUser, &temp) == NULL) {
		if (interp != NULL) {
		    Tcl_ResetResult(interp);
		    Tcl_AppendResult(interp, "user \"", expandedUser,
			    "\" doesn't exist", NULL);
		}
		Tcl_DStringFree(&userName);
		Tcl_DStringFree(&temp);



		return TCL_ERROR;
	    }

	    Tcl_DStringFree(&userName);

	}

	expandedUser = Tcl_DStringValue(&temp);
	transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp));

	if (split != len) {
	    /*

		}
		TclDecrRefCount(parts);
	    } else {
		Tcl_Obj *pair[2];

		pair[0] = transPtr;
		pair[1] = Tcl_NewStringObj(name+split+1, -1);
		transPtr = TclJoinPath(2, pair, 1);
		if (transPtr != pair[0]) {
		    TclDecrRefCount(pair[0]);
		}
		if (transPtr != pair[1]) {
		    TclDecrRefCount(pair[1]);
		}
	    }
	}
	Tcl_DStringFree(&temp);
    } else {
	transPtr = TclJoinPath(1, &pathPtr, 1);
    }

    /*
     * Now we have a translated filename in 'transPtr'. This will have forward
     * slashes on Windows, and will not contain any ~user sequences.
     */

    testsetplatform windows
    file tail {c:/foo\bar}
} bar
test cmdAH-9.51 {Tcl_FileObjCmd: tail} testsetplatform {
    testsetplatform windows
    file tail {foo\bar}
} bar
test cmdAH-9.52 {Tcl_FileObjCmd: tail / normalize, bug 7a9dc52b29} {
    list \
	[file tail {~/~foo}] \
	[file tail {~/test/~foo}] \
	[file tail [file normalize {~/~foo}]] \
	[file tail [file normalize {~/test/~foo}]]
} [lrepeat 4 ./~foo]

# rootname

test cmdAH-10.1 {Tcl_FileObjCmd: rootname} testsetplatform {
    testsetplatform unix
    list [catch {file rootname a b} msg] $msg
} {1 {wrong # args: should be "file rootname name"}}