tclfilename.c

tcl是工具命令语言

TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
    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 static string. */
    Tcl_Obj *unquotedPrefix;	/* 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 NULL. */
{
    char *separators;
    CONST char *head;
    char *tail, *start;
    char c;
    int result, prefixLen;
    Tcl_DString buffer;
    Tcl_Obj *oldResult;

    separators = NULL;		/* lint. */
    switch (tclPlatform) {
	case TCL_PLATFORM_UNIX:
	    separators = "/";
	    break;
	case TCL_PLATFORM_WINDOWS:
	    separators = "/\\:";
	    break;
	case TCL_PLATFORM_MAC:
#ifdef MAC_UNDERSTANDS_UNIX_PATHS
	    if (unquotedPrefix == NULL) {
		separators = (strchr(pattern, ':') == NULL) ? "/" : ":";
	    } else {
		separators = ":";
	    }
#else
	    separators = ":";
#endif
	    break;
    }

    Tcl_DStringInit(&buffer);
    if (unquotedPrefix != NULL) {
	start = Tcl_GetString(unquotedPrefix);
    } else {
	start = pattern;
    }

    /*
     * Perform tilde substitution, if needed.
     */

    if (start[0] == '~') {
	
	/*
	 * Find the first path separator after the tilde.
	 */
	for (tail = start; *tail != '\0'; tail++) {
	    if (*tail == '\\') {
		if (strchr(separators, tail[1]) != NULL) {
		    break;
		}
	    } else if (strchr(separators, *tail) != NULL) {
		break;
	    }
	}

	/*
	 * Determine the home directory for the specified user.  
	 */
	
	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);
	}
	*tail = c;
	if (head == NULL) {
	    if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
		return TCL_OK;
	    } else {
		return TCL_ERROR;
	    }
	}
	if (head != Tcl_DStringValue(&buffer)) {
	    Tcl_DStringAppend(&buffer, head, -1);
	}
	if (unquotedPrefix != NULL) {
	    Tcl_DStringAppend(&buffer, tail, -1);
	    tail = pattern;
	}
    } else {
	tail = pattern;
	if (unquotedPrefix != NULL) {
	    Tcl_DStringAppend(&buffer,Tcl_GetString(unquotedPrefix),-1);
	}
    }
    
    /* 
     * We want to remember the length of the current prefix,
     * in case we are using TCL_GLOBMODE_TAILS.  Also if we
     * are using TCL_GLOBMODE_DIR, we must make sure the
     * prefix ends in a directory separator.
     */
    prefixLen = Tcl_DStringLength(&buffer);

    if (prefixLen > 0) {
	c = Tcl_DStringValue(&buffer)[prefixLen-1];
	if (strchr(separators, c) == NULL) {
	    /* 
	     * If the prefix is a directory, make sure it ends in a
	     * directory separator.
	     */
	    if (globFlags & TCL_GLOBMODE_DIR) {
		Tcl_DStringAppend(&buffer,separators,1);
	    }
	    prefixLen++;
	}
    }

    /* 
     * We need to get the old result, in case it is over-written
     * below when we still need it.
     */
    oldResult = Tcl_GetObjResult(interp);
    Tcl_IncrRefCount(oldResult);
    Tcl_ResetResult(interp);
    
    result = TclDoGlob(interp, separators, &buffer, tail, types);
    
    if (result != TCL_OK) {
	if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
	    /* Put back the old result and reset the return code */
	    Tcl_SetObjResult(interp, oldResult);
	    result = TCL_OK;
	}
    } else {
	/* 
	 * Now we must concatenate the 'oldResult' and the current
	 * result, and then place that into the interpreter.
	 * 
	 * 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
	 * TclDoGlob, 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 slower (when
	 * the -tails flag is given), but much simpler to code.
	 */
	int objc, i;
	Tcl_Obj **objv;

	/* Ensure sole ownership */
	if (Tcl_IsShared(oldResult)) {
	    Tcl_DecrRefCount(oldResult);
	    oldResult = Tcl_DuplicateObj(oldResult);
	    Tcl_IncrRefCount(oldResult);
	}

	Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp), 
			       &objc, &objv);
#ifdef MAC_TCL
	/* adjust prefixLen if TclDoGlob prepended a ':' */
	if ((prefixLen > 0) && (objc > 0)
	&& (Tcl_DStringValue(&buffer)[0] != ':')) {
	    char *str = Tcl_GetStringFromObj(objv[0],NULL);
	    if (str[0] == ':') {
		    prefixLen++;
	    }
	}
#endif
	for (i = 0; i< objc; i++) {
	    Tcl_Obj* elt;
	    if (globFlags & TCL_GLOBMODE_TAILS) {
		int len;
		char *oldStr = Tcl_GetStringFromObj(objv[i],&len);
		if (len == prefixLen) {
		    if ((pattern[0] == '\0')
			|| (strchr(separators, pattern[0]) == NULL)) {
			elt = Tcl_NewStringObj(".",1);
		    } else {
			elt = Tcl_NewStringObj("/",1);
		    }
		} else {
		    elt = Tcl_NewStringObj(oldStr + prefixLen, 
						len - prefixLen);
		}
	    } else {
		elt = objv[i];
	    }
	    /* Assumption that 'oldResult' is a valid list */
	    Tcl_ListObjAppendElement(interp, oldResult, elt);
	}
	Tcl_SetObjResult(interp, oldResult);
    }
    /* 
     * Release our temporary copy.  All code paths above must
     * end here so we free our reference.
     */
    Tcl_DecrRefCount(oldResult);
    Tcl_DStringFree(&buffer);
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * SkipToChar --
 *
 *	This function traverses a glob pattern looking for the next
 *	unquoted occurance of the specified character at the same braces
 *	nesting level.
 *
 * 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 found at the top level, otherwise it is 0.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
SkipToChar(stringPtr, match)
    char **stringPtr;			/* Pointer string to check. */
    char *match;			/* Pointer to character to find. */
{
    int quoted, level;
    register char *p;

    quoted = 0;
    level = 0;

    for (p = *stringPtr; *p != '\0'; p++) {
	if (quoted) {
	    quoted = 0;
	    continue;
	}
	if ((level == 0) && (*p == *match)) {
	    *stringPtr = p;
	    return 1;
	}
	if (*p == '{') {
	    level++;
	} else if (*p == '}') {
	    level--;
	} else if (*p == '\\') {
	    quoted = 1;
	}
    }
    *stringPtr = p;
    return 0;
}

/*
 *----------------------------------------------------------------------
 *
 * TclDoGlob --
 *
 *	This recursive procedure forms the heart of the globbing
 *	code.  It performs a depth-first traversal of the tree
 *	given by the path name to be globbed.  The directory and
 *	remainder are assumed to be native format paths.  The prefix 
 *	contained in 'headPtr' is not used as a glob pattern, simply
 *	as a path specifier, so it can contain unquoted glob-sensitive
 *	characters (if the directories to which it points contain
 *	such strange characters).
 *
 * 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 be set to hold all of the file names
 *	given by the dir and rem arguments.  After an error the
 *	result in interp will hold an error message.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

int
TclDoGlob(interp, separators, headPtr, tail, types)
    Tcl_Interp *interp;		/* Interpreter to use for error reporting
				 * (e.g. unmatched brace). */
    char *separators;		/* String containing separator characters
				 * that should be used to identify globbing
				 * boundaries. */
    Tcl_DString *headPtr;	/* Completely expanded prefix. */
    char *tail;			/* The unexpanded remainder of the path.
				 * 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;
    int result = TCL_OK;
    char *name, *p, *openBrace, *closeBrace, *firstSpecialChar, savedChar;
    char lastChar = 0;
    
    int length = Tcl_DStringLength(headPtr);

    if (length > 0) {
	lastChar = Tcl_DStringValue(headPtr)[length-1];
    }

    /*
     * Consume any leading directory separators, leaving tail pointing
     * just past the last initial separator.
     */

    count = 0;
    name = tail;
    for (; *tail != '\0'; tail++) {
	if ((*tail == '\\') && (strchr(separators, tail[1]) != NULL)) {
	    tail++;
	} else if (strchr(separators, *tail) == NULL) {
	    break;
	}
	count++;
    }

    /*
     * Deal with path separators.  On the Mac, we have to watch out
     * for multiple separators, since they are special in Mac-style
     * paths.
     */

    switch (tclPlatform) {
	case TCL_PLATFORM_MAC:
#ifdef MAC_UNDERSTANDS_UNIX_PATHS
	    if (*separators == '/') {
		if (((length == 0) && (count == 0))
			|| ((length > 0) && (lastChar != ':'))) {
		    Tcl_DStringAppend(headPtr, ":", 1);
		}
	    } else {
#endif
		if (count == 0) {
		    if ((length > 0) && (lastChar != ':')) {
			Tcl_DStringAppend(headPtr, ":", 1);
		    }
		} else {
		    if (lastChar == ':') {
			count--;
		    }
		    while (count-- > 0) {
			Tcl_DStringAppend(headPtr, ":", 1);
		    }
		}
#ifdef MAC_UNDERSTANDS_UNIX_PATHS
	    }
#endif
	    break;
	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 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.
	     */
	    cygwin_conv_to_win32_path(Tcl_DStringValue(headPtr), winbuf);
	    Tcl_DStringFree(headPtr);
	    Tcl_DStringAppend(headPtr, winbuf, -1);

	    }
#endif /* __CYGWIN__ && __WIN32__ */

	    if (*name == ':') {
		Tcl_DStringAppend(headPtr, ":", 1);
		if (count > 1) {
		    Tcl_DStringAppend(headPtr, "/", 1);
		}
	    } else if ((*tail != '\0')
		    && (((length > 0)
			    && (strchr(separators, lastChar) == NULL))
			    || ((length == 0) && (count > 0)))) {
		Tcl_DStringAppend(headPtr, "/", 1);
		if ((length == 0) && (count > 1)) {
		    Tcl_DStringAppend(headPtr, "/", 1);
		}
	    }
	    
	    break;
	case TCL_PLATFORM_UNIX:
	    /*
	     * Add a separator if this is the first absolute element, or
	     * a later relative element.
	     */

	    if ((*tail != '\0')
		    && (((length > 0)
			    && (strchr(separators, lastChar) == NULL))
			    || ((length == 0) && (count > 0)))) {
		Tcl_DStringAppend(headPtr, "/", 1);
	    }
	    break;
    }

    /*
     * 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;
    for (p = tail; *p != '\0'; p++) {
	if (quoted) {
	    quoted = 0;
	} else if (*p == '\\') {
	    quoted = 1;
	    if (strchr(separators, p[1]) != NULL) {
		break;			/* Quoted directory separator. */
	    }
	} else if (strchr(separators, *p) != NULL) {
	    break;			/* Unquoted directory separator. */
	} else if (*p == '{') {
	    openBrace = p;
	    p++;
	    if (SkipToChar(&p, "}")) {
		closeBrace = p;		/* Balanced braces. */
		break;
	    }
	    Tcl_SetResult(interp, "unmatched open-brace in file name",
		    TCL_STATIC);
	    return TCL_ERROR;
	} else if (*p == '}') {
	    Tcl_SetResult(interp, "unmatched close-brace in file name",
		    TCL_STATIC);
	    return TCL_ERROR;
	}
    }

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

	Tcl_DStringAppend(&newName, tail, openBrace-tail);
	baseLength = Tcl_DStringLength(&newName);
	length = Tcl_DStringLength(headPtr);
	*closeBrace = '\0';
	for (p = openBrace; p != closeBrace; ) {
	    p++;
	    element = p;
	    SkipToChar(&p, ",");
	    Tcl_DStringSetLength(headPtr, length);
	    Tcl_DStringSetLength(&newName, baseLength);
	    Tcl_DStringAppend(&newName, element, p-element);
	    Tcl_DStringAppend(&newName, closeBrace+1, -1);
	    result = TclDoGlob(interp, separators, headPtr, 
			       Tcl_DStringValue(&newName), types);
	    if (result != TCL_OK) {
		break;
	    }
	}
	*closeBrace = '}';
	Tcl_DStringFree(&newName);
	return result;
    }

    /*
     * At this point, there are no more brace substitutions to perform on
     * this path component.  The variable p is pointing at a quoted or
     * unquoted directory separator or the end of the string.  So we need
     * to check for special globbing characters in the current pattern.
     * We avoid modifying tail if p is pointing at the end of the string.
     */

    if