tclfilename.c

tcl是工具命令语言

		Tcl_ListObjAppendElement(NULL, result, 
			Tcl_NewStringObj(elementStart, -1));
	    }
	}
    } else {

	/*
	 * Split on slashes, suppress extra /'s, and convert .. to ::. 
	 */

	for (;;) {
	    elementStart = p;
	    while ((*p != '\0') && (*p != '/')) {
		p++;
	    }
	    length = p - elementStart;
	    if (length > 0) {
		if ((length == 1) && (elementStart[0] == '.')) {
		    Tcl_ListObjAppendElement(NULL, result, 
					     Tcl_NewStringObj(":", 1));
		} else if ((length == 2) && (elementStart[0] == '.')
			&& (elementStart[1] == '.')) {
		    Tcl_ListObjAppendElement(NULL, result, 
					     Tcl_NewStringObj("::", 2));
		} else {
		    Tcl_Obj *nextElt;
		    if (*elementStart == '~') {
			nextElt = Tcl_NewStringObj(":",1);
			Tcl_AppendToObj(nextElt, elementStart, length);
		    } else {
			nextElt = Tcl_NewStringObj(elementStart, length);
		    }
		    Tcl_ListObjAppendElement(NULL, result, nextElt);
		}
	    }
	    if (*p++ == '\0') {
		break;
	    }
	}
    }
    return result;
}

/*
 *---------------------------------------------------------------------------
 *
 * Tcl_FSJoinToPath --
 *
 *      This function takes the given object, which should usually be a
 *      valid path or NULL, and joins onto it the array of paths
 *      segments given.
 *
 * Results:
 *      Returns object with refCount of zero
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj* 
Tcl_FSJoinToPath(basePtr, objc, objv)
    Tcl_Obj *basePtr;
    int objc;
    Tcl_Obj *CONST objv[];
{
    int i;
    Tcl_Obj *lobj, *ret;

    if (basePtr == NULL) {
	lobj = Tcl_NewListObj(0, NULL);
    } else {
	lobj = Tcl_NewListObj(1, &basePtr);
    }
    
    for (i = 0; i<objc;i++) {
	Tcl_ListObjAppendElement(NULL, lobj, objv[i]);
    }
    ret = Tcl_FSJoinPath(lobj, -1);
    Tcl_DecrRefCount(lobj);
    return ret;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpNativeJoinPath --
 *
 *      'prefix' is absolute, 'joining' is relative to prefix.
 *
 * Results:
 *      modifies prefix
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

void
TclpNativeJoinPath(prefix, joining)
    Tcl_Obj *prefix;
    char* joining;
{
    int length, needsSep;
    char *dest, *p, *start;
    
    start = Tcl_GetStringFromObj(prefix, &length);

    /*
     * Remove the ./ from tilde prefixed elements unless
     * it is the first component.
     */
    
    p = joining;
    
    if (length != 0) {
	if ((p[0] == '.') && (p[1] == '/') && (p[2] == '~')) {
	    p += 2;
	}
    }
       
    if (*p == '\0') {
	return;
    }


    switch (tclPlatform) {
        case TCL_PLATFORM_UNIX:
	    /*
	     * Append a separator if needed.
	     */

	    if (length > 0 && (start[length-1] != '/')) {
		Tcl_AppendToObj(prefix, "/", 1);
		length++;
	    }
	    needsSep = 0;
	    
	    /*
	     * Append the element, eliminating duplicate and trailing
	     * slashes.
	     */

	    Tcl_SetObjLength(prefix, length + (int) strlen(p));
	    
	    dest = Tcl_GetString(prefix) + length;
	    for (; *p != '\0'; p++) {
		if (*p == '/') {
		    while (p[1] == '/') {
			p++;
		    }
		    if (p[1] != '\0') {
			if (needsSep) {
			    *dest++ = '/';
			}
		    }
		} else {
		    *dest++ = *p;
		    needsSep = 1;
		}
	    }
	    length = dest - Tcl_GetString(prefix);
	    Tcl_SetObjLength(prefix, length);
	    break;

	case TCL_PLATFORM_WINDOWS:
	    /*
	     * Check to see if we need to append a separator.
	     */

	    if ((length > 0) && 
		(start[length-1] != '/') && (start[length-1] != ':')) {
		Tcl_AppendToObj(prefix, "/", 1);
		length++;
	    }
	    needsSep = 0;
	    
	    /*
	     * Append the element, eliminating duplicate and
	     * trailing slashes.
	     */

	    Tcl_SetObjLength(prefix, length + (int) strlen(p));
	    dest = Tcl_GetString(prefix) + length;
	    for (; *p != '\0'; p++) {
		if ((*p == '/') || (*p == '\\')) {
		    while ((p[1] == '/') || (p[1] == '\\')) {
			p++;
		    }
		    if ((p[1] != '\0') && needsSep) {
			*dest++ = '/';
		    }
		} else {
		    *dest++ = *p;
		    needsSep = 1;
		}
	    }
	    length = dest - Tcl_GetString(prefix);
	    Tcl_SetObjLength(prefix, length);
	    break;

	case TCL_PLATFORM_MAC: {
	    int newLength;
	    
	    /*
	     * Sort out separators.  We basically add the object we've
	     * been given, but we have to make sure that there is
	     * exactly one separator inbetween (unless the object we're
	     * adding contains multiple contiguous colons, all of which
	     * we must add).  Also if an object is just ':' we don't
	     * bother to add it unless it's the very first element.
	     */

#ifdef MAC_UNDERSTANDS_UNIX_PATHS
	    int adjustedPath = 0;
	    if ((strchr(p, ':') == NULL) && (strchr(p, '/') != NULL)) {
		char *start = p;
		adjustedPath = 1;
		while (*start != '\0') {
		    if (*start == '/') {
		        *start = ':';
		    }
		    start++;
		}
	    }
#endif
	    if (length > 0) {
		if ((p[0] == ':') && (p[1] == '\0')) {
		    return;
		}
		if (start[length-1] != ':') {
		    if (*p != '\0' && *p != ':') {
			Tcl_AppendToObj(prefix, ":", 1);
			length++;
		    }
		} else if (*p == ':') {
		    p++;
		}
	    } else {
		if (*p != '\0' && *p != ':') {
		    Tcl_AppendToObj(prefix, ":", 1);
		    length++;
		}
	    }
	    
	    /*
	     * Append the element
	     */

	    newLength = strlen(p);
	    /* 
	     * It may not be good to just do 'Tcl_AppendToObj(prefix,
	     * p, newLength)' because the object may contain duplicate
	     * colons which we want to get rid of.
	     */
	    Tcl_AppendToObj(prefix, p, newLength);
	    
	    /* Remove spurious trailing single ':' */
	    dest = Tcl_GetString(prefix) + length + newLength;
	    if (*(dest-1) == ':') {
		if (dest-1 > Tcl_GetString(prefix)) {
		    if (*(dest-2) != ':') {
		        Tcl_SetObjLength(prefix, length + newLength -1);
		    }
		}
	    }
#ifdef MAC_UNDERSTANDS_UNIX_PATHS
	    /* Revert the path to what it was */
	    if (adjustedPath) {
		char *start = joining;
		while (*start != '\0') {
		    if (*start == ':') {
			*start = '/';
		    }
		    start++;
		}
	    }
#endif
	    break;
	}
    }
    return;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_JoinPath --
 *
 *	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 Tcl_DString must already be initialized.
 *
 * Side effects:
 *	Modifies the Tcl_DString.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_JoinPath(argc, argv, resultPtr)
    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,
		Tcl_NewStringObj(argv[i], -1));
    }

    /* Ask the objectified code to join the paths */
    Tcl_IncrRefCount(listObj);
    resultObj = Tcl_FSJoinPath(listObj, argc);
    Tcl_IncrRefCount(resultObj);
    Tcl_DecrRefCount(listObj);

    /* Store the result */
    resultStr = Tcl_GetStringFromObj(resultObj, &len);
    Tcl_DStringAppend(resultPtr, resultStr, len);
    Tcl_DecrRefCount(resultObj);

    /* Return a pointer to the result */
    return Tcl_DStringValue(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 where the tilde and following characters have been replaced
 *	by the home directory location for the named user.
 *
 * Results:
 *	The return value is a pointer to a string containing the name
 *	after tilde substitution.  If there was no tilde substitution,
 *	the return value is a pointer to a copy of the original string.
 *	If there was an error in processing the name, then an error
 *	message is left in the interp's result (if interp was not NULL)
 *	and the return value is NULL.  Space for the return value is
 *	allocated in bufferPtr; the caller must call Tcl_DStringFree()
 *	to free the space if the return value was not NULL.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

char *
Tcl_TranslateFileName(interp, name, bufferPtr)
    Tcl_Interp *interp;		/* Interpreter in which to store error
				 * message (if necessary). */
    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 name after tilde substitution. */
{
    Tcl_Obj *path = Tcl_NewStringObj(name, -1);
    CONST char *result;

    Tcl_IncrRefCount(path);
    result = Tcl_FSGetTranslatedStringPath(interp, path);
    if (result == NULL) {
	Tcl_DecrRefCount(path);
	return NULL;
    }
    Tcl_DStringInit(bufferPtr);
    Tcl_DStringAppend(bufferPtr, result, -1);
    Tcl_DecrRefCount(path);

    /*
     * Convert forward slashes to backslashes in Windows paths because
     * some system interfaces don't accept forward slashes.
     */

    if (tclPlatform == TCL_PLATFORM_WINDOWS) {
#if defined(__CYGWIN__) && defined(__WIN32__)

	extern int cygwin_conv_to_win32_path 
	    _ANSI_ARGS_((CONST char *, char *));
	char winbuf[MAX_PATH];

	/*
	 * In the Cygwin world, call conv_to_win32_path in order to use the
	 * mount table to translate the file name into something Windows will
	 * understand.  Take care when converting empty strings!
	 */
	if (Tcl_DStringLength(bufferPtr)) {
	    cygwin_conv_to_win32_path(Tcl_DStringValue(bufferPtr), winbuf);
	    Tcl_DStringFree(bufferPtr);
	    Tcl_DStringAppend(bufferPtr, winbuf, -1);
	}
#else /* __CYGWIN__ && __WIN32__ */

	register char *p;
	for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
	    if (*p == '/') {
		*p = '\\';
	    }
	}
#endif /* __CYGWIN__ && __WIN32__ */
    }
    return Tcl_DStringValue(bufferPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * TclGetExtension --
 *
 *	This function returns a pointer to the beginning of the
 *	extension part of a file name.
 *
 * Results:
 *	Returns a pointer into name which indicates where the extension
 *	starts.  If there is no extension, returns NULL.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

char *
TclGetExtension(name)
    char *name;			/* File name to parse. */
{
    char *p, *lastSep;

    /*
     * First find the last directory separator.
     */

    lastSep = NULL;		/* Needed only to prevent gcc warnings. */
    switch (tclPlatform) {
	case TCL_PLATFORM_UNIX:
	    lastSep = strrchr(name, '/');
	    break;

	case TCL_PLATFORM_MAC:
#ifdef MAC_UNDERSTANDS_UNIX_PATHS
	    if (strchr(name, ':') == NULL) {
		lastSep = strrchr(name, '/');
	    } else {
		lastSep = strrchr(name, ':');
	    }
#else
	    lastSep = strrchr(name, ':');
#endif
	    break;

	case TCL_PLATFORM_WINDOWS:
	    lastSep = NULL;
	    for (p = name; *p != '\0'; p++) {
		if (strchr("/\\:", *p) != NULL) {
		    lastSep = p;
		}
	    }
	    break;
    }
    p = strrchr(name, '.');
    if ((p != NULL) && (lastSep != NULL) && (lastSep > p)) {
	p = NULL;
    }

    /*
     * 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
     * confusing and usually incorrect behavior, so now we split at the last
     * period in the name.
     */

    return p;
}

/*
 *----------------------------------------------------------------------
 *
 * DoTildeSubst --
 *
 *	Given a string following a tilde, this routine returns the
 *	corresponding home directory.
 *
 * Results:
 *	The result is a pointer to a static string containing the home