tclfilename.c

tcl是工具命令语言

	}
    }
    return type;
}

/*
 *---------------------------------------------------------------------------
 *
 * TclpNativeSplitPath --
 *
 *      This function takes the given Tcl_Obj, which should be a valid
 *      path, and returns a Tcl List object containing each segment
 *      of that path as an element.
 *
 *      Note this function currently calls the older Split(Plat)Path
 *      functions, which require more memory allocation than is
 *      desirable.
 *      
 * Results:
 *      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.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */

Tcl_Obj* 
TclpNativeSplitPath(pathPtr, lenPtr)
    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. */

    /*
     * Perform platform specific splitting. 
     */

    switch (tclPlatform) {
	case TCL_PLATFORM_UNIX:
	    resultPtr = SplitUnixPath(Tcl_GetString(pathPtr));
	    break;

	case TCL_PLATFORM_WINDOWS:
	    resultPtr = SplitWinPath(Tcl_GetString(pathPtr));
	    break;
	    
	case TCL_PLATFORM_MAC:
	    resultPtr = SplitMacPath(Tcl_GetString(pathPtr));
	    break;
    }

    /*
     * Compute the number of elements in the result.
     */

    if (lenPtr != NULL) {
	Tcl_ListObjLength(NULL, resultPtr, lenPtr);
    }
    return resultPtr;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_SplitPath --
 *
 *	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 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:  *argvPtr and *argcPtr are only modified
 *	if the procedure returns normally.
 *
 * Side effects:
 *	Allocates memory.
 *
 *----------------------------------------------------------------------
 */

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 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);
    resultPtr = Tcl_FSSplitPath(tmpPtr, argcPtr);
    Tcl_DecrRefCount(tmpPtr);

    /* Calculate space required for the result */
    
    size = 1;
    for (i = 0; i < *argcPtr; i++) {
	Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
	Tcl_GetStringFromObj(eltPtr, &len);
	size += len + 1;
    }
    
    /*
     * Allocate a buffer large enough to hold the contents of all of
     * the list plus the argv pointers and the terminating NULL pointer.
     */

    *argvPtr = (CONST char **) ckalloc((unsigned)
	    ((((*argcPtr) + 1) * sizeof(char *)) + size));

    /*
     * Position p after the last argv pointer and copy the contents of
     * the list in, piece by piece.
     */

    p = (char *) &(*argvPtr)[(*argcPtr) + 1];
    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);
	p += len+1;
    }
    
    /*
     * Now set up the argv pointers.
     */

    p = (char *) &(*argvPtr)[(*argcPtr) + 1];

    for (i = 0; i < *argcPtr; i++) {
	(*argvPtr)[i] = p;
	while ((*p++) != '\0') {}
    }
    (*argvPtr)[i] = NULL;

    /*
     * Free the result ptr given to us by Tcl_FSSplitPath
     */

    Tcl_DecrRefCount(resultPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * SplitUnixPath --
 *
 *	This routine is used by Tcl_(FS)SplitPath to handle splitting
 *	Unix paths.
 *
 * Results:
 *	Returns a newly allocated Tcl list object.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj*
SplitUnixPath(path)
    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

    if (path[0] == '/') {
	Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj("/",1));
	p = path+1;
    } else {
	p = path;
    }

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


/*
 *----------------------------------------------------------------------
 *
 * SplitWinPath --
 *
 *	This routine is used by Tcl_(FS)SplitPath to handle splitting
 *	Windows paths.
 *
 * Results:
 *	Returns a newly allocated Tcl list object.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj*
SplitWinPath(path)
    CONST char *path;		/* Pointer to string containing a path. */
{
    int length;
    CONST char *p, *elementStart;
    Tcl_PathType type = TCL_PATH_ABSOLUTE;
    Tcl_DString buf;
    Tcl_Obj *result = Tcl_NewObj();
    Tcl_DStringInit(&buf);
    
    p = ExtractWinRoot(path, &buf, 0, &type);

    /*
     * Terminate the root portion, if we matched something.
     */

    if (p != path) {
	Tcl_ListObjAppendElement(NULL, result, 
				 Tcl_NewStringObj(Tcl_DStringValue(&buf), 
						  Tcl_DStringLength(&buf)));
    }
    Tcl_DStringFree(&buf);
    
    /*
     * Split on slashes.  Embedded elements that start with tilde will be
     * prefixed with "./" so they are not affected by tilde substitution.
     */

    do {
	elementStart = p;
	while ((*p != '\0') && (*p != '/') && (*p != '\\')) {
	    p++;
	}
	length = p - elementStart;
	if (length > 0) {
	    Tcl_Obj *nextElt;
	    if ((elementStart[0] == '~') && (elementStart != path)) {
		nextElt = Tcl_NewStringObj("./",2);
		Tcl_AppendToObj(nextElt, elementStart, length);
	    } else {
		nextElt = Tcl_NewStringObj(elementStart, length);
	    }
	    Tcl_ListObjAppendElement(NULL, result, nextElt);
	}
    } while (*p++ != '\0');

    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * SplitMacPath --
 *
 *	This routine is used by Tcl_(FS)SplitPath to handle splitting
 *	Macintosh paths.
 *
 * Results:
 *	Returns a newly allocated Tcl list object.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj*
SplitMacPath(path)
    CONST char *path;		/* Pointer to string containing a path. */
{
    int isMac = 0;		/* 1 if is Mac-style, 0 if Unix-style path. */
    int length;
    CONST char *p, *elementStart;
    Tcl_Obj *result;
#ifdef MAC_UNDERSTANDS_UNIX_PATHS
    Tcl_RegExp re;
    int i;
    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
#endif
    
    result = Tcl_NewObj();
    
#ifdef MAC_UNDERSTANDS_UNIX_PATHS
    /*
     * Initialize the path name parser for Macintosh path names.
     */

    FileNameInit();

    /*
     * Match the root portion of a Mac path name.
     */

    i = 0;			/* Needed only to prevent gcc warnings. */

    re = Tcl_GetRegExpFromObj(NULL, tsdPtr->macRootPatternPtr, REG_ADVANCED);

    if (Tcl_RegExpExec(NULL, re, path, path) == 1) {
	CONST char *start, *end;
	Tcl_Obj *nextElt;

	/*
	 * Treat degenerate absolute paths like / and /../.. as
	 * Mac relative file names for lack of anything else to do.
	 */

	Tcl_RegExpRange(re, 2, &start, &end);
	if (start) {
	    Tcl_Obj *elt = Tcl_NewStringObj(":", 1);
	    Tcl_RegExpRange(re, 0, &start, &end);
	    Tcl_AppendToObj(elt, path, end - start);
	    Tcl_ListObjAppendElement(NULL, result, elt);
	    return result;
	}

	Tcl_RegExpRange(re, 5, &start, &end);
	if (start) {
	    /*
	     * Unix-style tilde prefixed paths.
	     */

	    isMac = 0;
	    i = 5;
	} else {
	    Tcl_RegExpRange(re, 7, &start, &end);
	    if (start) {
		/*
		 * Mac-style tilde prefixed paths.
		 */

		isMac = 1;
		i = 7;
	    } else {
		Tcl_RegExpRange(re, 10, &start, &end);
		if (start) {
		    /*
		     * Normal Unix style paths.
		     */

		    isMac = 0;
		    i = 10;
		} else {
		    Tcl_RegExpRange(re, 12, &start, &end);
		    if (start) {
			/*
			 * Normal Mac style paths.
			 */

			isMac = 1;
			i = 12;
		    }
		}
	    }
	}
	Tcl_RegExpRange(re, i, &start, &end);
	length = end - start;

	/*
	 * Append the element and terminate it with a : 
	 */

	nextElt = Tcl_NewStringObj(start, length);
	Tcl_AppendToObj(nextElt, ":", 1);
	Tcl_ListObjAppendElement(NULL, result, nextElt);
	p = end;
    } else {
	isMac = (strchr(path, ':') != NULL);
	p = path;
    }
#else
    if ((path[0] != ':') && (path[0] == '~' || (strchr(path,':') != NULL))) {
	CONST char *end;
	Tcl_Obj *nextElt;

	isMac = 1;
	
	end = strchr(path,':');
	if (end == NULL) {
	    length = strlen(path);
	} else {
	    length = end - path;
	}

	/*
	 * Append the element and terminate it with a :
	 */

	nextElt = Tcl_NewStringObj(path, length);
	Tcl_AppendToObj(nextElt, ":", 1);
	Tcl_ListObjAppendElement(NULL, result, nextElt);
	p = path + length;
    } else {
	isMac = (strchr(path, ':') != NULL);
	isMac = 1;
	p = path;
    }
#endif
    
    if (isMac) {

	/*
	 * p is pointing at the first colon in the path.  There
	 * will always be one, since this is a Mac-style path.
	 * (This is no longer true if MAC_UNDERSTANDS_UNIX_PATHS 
	 * is false, so we must check whether 'p' points to the
	 * end of the string.)
	 */
	elementStart = p;
	if (*p == ':') {
	    p++;
	}
	
	while ((p = strchr(p, ':')) != NULL) {
	    length = p - elementStart;
	    if (length == 1) {
		while (*p == ':') {
		    Tcl_ListObjAppendElement(NULL, result,
			    Tcl_NewStringObj("::", 2));
		    elementStart = p++;
		}
	    } else {
		/*
		 * If this is a simple component, drop the leading colon.
		 */

		if ((elementStart[1] != '~')
			&& (strchr(elementStart+1, '/') == NULL)) {
		    elementStart++;
		    length--;
		}
		Tcl_ListObjAppendElement(NULL, result, 
			Tcl_NewStringObj(elementStart, length));
		elementStart = p++;
	    }
	}
	if (elementStart[0] != ':') {
	    if (elementStart[0] != '\0') {
		Tcl_ListObjAppendElement(NULL, result, 
			Tcl_NewStringObj(elementStart, -1));
	    }
	} else {
	    if (elementStart[1] != '\0' || elementStart == path) {
		if ((elementStart[1] != '~') && (elementStart[1] != '\0')
			&& (strchr(elementStart+1, '/') == NULL)) {
		    elementStart++;
		}