tclfilename.c

linux系统下的音频通信

            home_var = "HOME";
#endif
            dir = TclGetEnv(home_var);
            if (dir == NULL) {
	    if (interp) {
		Tcl_ResetResult(interp);
		Tcl_AppendResult(interp, "couldn't find environment variable specifying home directory: ", home_var, (char *) NULL);
	    }
	    return NULL;
	}
	Tcl_JoinPath(1, &dir, resultPtr);
    } else {
	
	/* lint, TclGetuserHome() always NULL under windows. */
	if (TclGetUserHome(user, resultPtr) == NULL) {	
	    if (interp) {
		Tcl_ResetResult(interp);
		Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist",
			(char *) NULL);
	    }
	    return NULL;
	}
    }
    return resultPtr->string;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GlobCmd --
 *
 *	This procedure is invoked to process the "glob" Tcl command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int
Tcl_GlobCmd(dummy, interp, argc, argv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int argc;				/* Number of arguments. */
    char **argv;			/* Argument strings. */
{
    int i, noComplain, firstArg;
    char c;
    int result = TCL_OK;
    Tcl_DString buffer;
    char *separators, *head, *tail;

    noComplain = 0;
    for (firstArg = 1; (firstArg < argc) && (argv[firstArg][0] == '-');
	    firstArg++) {
	if (strcmp(argv[firstArg], "-nocomplain") == 0) {
	    noComplain = 1;
	} else if (strcmp(argv[firstArg], "--") == 0) {
	    firstArg++;
	    break;
	} else {
	    Tcl_AppendResult(interp, "bad switch \"", argv[firstArg],
		    "\": must be -nocomplain or --", (char *) NULL);
	    return TCL_ERROR;
	}
    }
    if (firstArg >= argc) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
		" ?switches? name ?name ...?\"", (char *) NULL);
	return TCL_ERROR;
    }

    Tcl_DStringInit(&buffer);
    separators = NULL;		/* Needed only to prevent gcc warnings. */
    for (i = firstArg; i < argc; i++) {
	switch (tclPlatform) {
	case TCL_PLATFORM_UNIX:
	    separators = "/";
	    break;
	case TCL_PLATFORM_WINDOWS:
	    separators = "/\\:";
	    break;
	case TCL_PLATFORM_MAC:
	    separators = (strchr(argv[i], ':') == NULL) ? "/" : ":";
	    break;
	}

	Tcl_DStringSetLength(&buffer, 0);

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

	if (argv[i][0] == '~') {
	    char *p;

	    /*
	     * Find the first path separator after the tilde.
	     */

	    for (tail = argv[i]; *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.  Note that
	     * we don't allow special characters in the user name.
	     */

	    c = *tail;
	    *tail = '\0';
	    p = strpbrk(argv[i]+1, "\\[]*?{}");
	    if (p == NULL) {
		head = DoTildeSubst(interp, argv[i]+1, &buffer);
	    } else {
		if (!noComplain) {
		    Tcl_ResetResult(interp);
		    Tcl_AppendResult(interp, "globbing characters not ",
			    "supported in user names", (char *) NULL);
		}
		head = NULL;
	    }
	    *tail = c;
	    if (head == NULL) {
		if (noComplain) {
		    Tcl_ResetResult(interp);
		    continue;
		} else {
		    result = TCL_ERROR;
		    goto done;
		}
	    }
	    if (head != Tcl_DStringValue(&buffer)) {
		Tcl_DStringAppend(&buffer, head, -1);
	    }
	} else {
	    tail = argv[i];
	}

	result = TclDoGlob(interp, separators, &buffer, tail);
	if (result != TCL_OK) {
	    if (noComplain) {
		/*
		 * We should in fact pass down the nocomplain flag 
		 * or save the interp result or use another mecanism
		 * so the interp result is not mangled on errors in that case.
		 * but that would a bigger change than reasonable for a patch
		 * release.
		 * (see fileName.test 15.2-15.4 for expected behaviour)
		 */
		Tcl_ResetResult(interp);
		result = TCL_OK;
		continue;
	    } else {
		goto done;
	    }
	}
    }

    if ((*interp->result == 0) && !noComplain) {
	char *sep = "";

	Tcl_AppendResult(interp, "no files matched glob pattern",
		(argc == 2) ? " \"" : "s \"", (char *) NULL);
	for (i = firstArg; i < argc; i++) {
	    Tcl_AppendResult(interp, sep, argv[i], (char *) NULL);
	    sep = " ";
	}
	Tcl_AppendResult(interp, "\"", (char *) NULL);
	result = TCL_ERROR;
    }
done:
    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.
 *
 * 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)
    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. */
{
    int baseLength, quoted, count;
    int result = TCL_OK;
    char *p, *openBrace, *closeBrace, *name, *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:
	    if (*separators == '/') {
		if (((length == 0) && (count == 0))
			|| ((length > 0) && (lastChar != ':'))) {
		    Tcl_DStringAppend(headPtr, ":", 1);
		}
	    } else {
		if (count == 0) {
		    if ((length > 0) && (lastChar != ':')) {
			Tcl_DStringAppend(headPtr, ":", 1);
		    }
		} else {
		    if (lastChar == ':') {
			count--;
		    }
		    while (count-- > 0) {
			Tcl_DStringAppend(headPtr, ":", 1);
		    }
		}
	    }
	    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 (*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));
	    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 (*p != '\0') {
	 savedChar = *p;
	 *p = '\0';
	 firstSpecialChar = strpbrk(tail, "*[]?\\");
	 *p = savedChar;
    } else {
	firstSpecialChar = strpbrk(tail, "*[]?\\");
    }

    if (firstSpecialChar != NULL) {
	/*
	 * Look for matching files in the current directory.  The
	 * implementation of this function is platform specific, but may
	 * recursively call TclDoGlob.  For each file that matches, it will
	 * add the match onto the interp->result, or call TclDoGlob if there
	 * are more characters to be processed.
	 */

	return TclMatchFiles(interp, separators, headPtr, tail, p);
    }
    Tcl_DStringAppend(headPtr, tail, p-tail);
    if (*p != '\0') {
	return TclDoGlob(interp, separators, headPtr, p);
    }

    /*
     * There are no more wildcards in the pattern and no more unprocessed
     * characters in the tail, so now we can construct the path and verify
     * the existence of the file.
     */

    switch (tclPlatform) {
	case TCL_PLATFORM_MAC:
	    if (strchr(Tcl_DStringValue(headPtr), ':') == NULL) {
		Tcl_DStringAppend(headPtr, ":", 1);
	    }
	    name = Tcl_DStringValue(headPtr);
	    if (TclAccess(name, F_OK) == 0) {
		if ((name[1] != '\0') && (strchr(name+1, ':') == NULL)) {
		    Tcl_AppendElement(interp, name+1);
		} else {
		    Tcl_AppendElement(interp, name);
		}
	    }
	    break;
	case TCL_PLATFORM_WINDOWS: {
	    int exists;
	    /*
	     * We need to convert slashes to backslashes before checking
	     * for the existence of the file.  Once we are done, we need
	     * to convert the slashes back.
	     */

	    if (Tcl_DStringLength(headPtr) == 0) {
		if (((*name == '\\') && (name[1] == '/' || name[1] == '\\'))
			|| (*name == '/')) {
		    Tcl_DStringAppend(headPtr, "\\", 1);
		} else {
		    Tcl_DStringAppend(headPtr, ".", 1);
		}
	    } else {
		for (p = Tcl_DStringValue(headPtr); *p != '\0'; p++) {
		    if (*p == '/') {
			*p = '\\';
		    }
		}
	    }
	    name = Tcl_DStringValue(headPtr);
	    exists = (TclAccess(name, F_OK) == 0);
	    for (p = name; *p != '\0'; p++) {
		if (*p == '\\') {
		    *p = '/';
		}
	    }
	    if (exists) {
		Tcl_AppendElement(interp, name);
	    }
	    break;
	}
	case TCL_PLATFORM_UNIX:
	    if (Tcl_DStringLength(headPtr) == 0) {
		if ((*name == '\\' && name[1] == '/') || (*name == '/')) {
		    Tcl_DStringAppend(headPtr, "/", 1);
		} else {
		    Tcl_DStringAppend(headPtr, ".", 1);
		}
	    }
	    name = Tcl_DStringValue(headPtr);
	    if (TclAccess(name, F_OK) == 0) {
		Tcl_AppendElement(interp, name);
	    }
	    break;
    }

    return TCL_OK;
}