tclfilename.c

tcl是工具命令语言

 *	directory in native format.  If there was an error in processing
 *	the substitution, then an error message is left in the interp's
 *	result and the return value is NULL.  On success, the results
 *	are appended to resultPtr, and the contents of resultPtr are
 *	returned.
 *
 * Side effects:
 *	Information may be left in resultPtr.
 *
 *----------------------------------------------------------------------
 */

static CONST char *
DoTildeSubst(interp, user, resultPtr)
    Tcl_Interp *interp;		/* Interpreter in which to store error
				 * message (if necessary). */
    CONST char *user;		/* Name of user whose home directory should be
				 * substituted, or "" for current user. */
    Tcl_DString *resultPtr;	/* Initialized DString filled with name
				 * after tilde substitution. */
{
    CONST char *dir;

    if (*user == '\0') {
	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", (char *) NULL);
	    }
	    return NULL;
	}
	Tcl_JoinPath(1, &dir, resultPtr);
	Tcl_DStringFree(&dirString);
    } else {
	if (TclpGetUserHome(user, resultPtr) == NULL) {	
	    if (interp) {
		Tcl_ResetResult(interp);
		Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist",
			(char *) NULL);
	    }
	    return NULL;
	}
    }
    return Tcl_DStringValue(resultPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_GlobObjCmd --
 *
 *	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_GlobObjCmd(dummy, interp, objc, objv)
    ClientData dummy;			/* Not used. */
    Tcl_Interp *interp;			/* Current interpreter. */
    int objc;				/* Number of arguments. */
    Tcl_Obj *CONST objv[];		/* Argument objects. */
{
    int index, i, globFlags, length, join, dir, result;
    char *string, *separators;
    Tcl_Obj *typePtr, *resultPtr, *look;
    Tcl_Obj *pathOrDir = NULL;
    Tcl_DString prefix;
    static CONST char *options[] = {
	"-directory", "-join", "-nocomplain", "-path", "-tails", 
	"-types", "--", NULL
    };
    enum options {
	GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS, 
	GLOB_TYPE, GLOB_LAST
    };
    enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1};
    Tcl_GlobTypeData *globTypes = NULL;

    globFlags = 0;
    join = 0;
    dir = PATH_NONE;
    typePtr = NULL;
    resultPtr = Tcl_GetObjResult(interp);
    for (i = 1; i < objc; i++) {
	if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
		!= TCL_OK) {
	    string = Tcl_GetStringFromObj(objv[i], &length);
	    if (string[0] == '-') {
		/*
		 * It looks like the command contains an option so signal
		 * an error
		 */
		return TCL_ERROR;
	    } else {
		/*
		 * This clearly isn't an option; assume it's the first
		 * glob pattern.  We must clear the error
		 */
		Tcl_ResetResult(interp);
		break;
	    }
	}
	switch (index) {
	    case GLOB_NOCOMPLAIN:			/* -nocomplain */
	        globFlags |= TCL_GLOBMODE_NO_COMPLAIN;
		break;
	    case GLOB_DIR:				/* -dir */
		if (i == (objc-1)) {
		    Tcl_AppendToObj(resultPtr,
			    "missing argument to \"-directory\"", -1);
		    return TCL_ERROR;
		}
		if (dir != PATH_NONE) {
		    Tcl_AppendToObj(resultPtr,
			    "\"-directory\" cannot be used with \"-path\"",
			    -1);
		    return TCL_ERROR;
		}
		dir = PATH_DIR;
		globFlags |= TCL_GLOBMODE_DIR;
		pathOrDir = objv[i+1];
		i++;
		break;
	    case GLOB_JOIN:				/* -join */
		join = 1;
		break;
	    case GLOB_TAILS:				/* -tails */
	        globFlags |= TCL_GLOBMODE_TAILS;
		break;
	    case GLOB_PATH:				/* -path */
	        if (i == (objc-1)) {
		    Tcl_AppendToObj(resultPtr,
			    "missing argument to \"-path\"", -1);
		    return TCL_ERROR;
		}
		if (dir != PATH_NONE) {
		    Tcl_AppendToObj(resultPtr,
			    "\"-path\" cannot be used with \"-directory\"",
			    -1);
		    return TCL_ERROR;
		}
		dir = PATH_GENERAL;
		pathOrDir = objv[i+1];
		i++;
		break;
	    case GLOB_TYPE:				/* -types */
	        if (i == (objc-1)) {
		    Tcl_AppendToObj(resultPtr,
			    "missing argument to \"-types\"", -1);
		    return TCL_ERROR;
		}
		typePtr = objv[i+1];
		if (Tcl_ListObjLength(interp, typePtr, &length) != TCL_OK) {
		    return TCL_ERROR;
		}
		i++;
		break;
	    case GLOB_LAST:				/* -- */
	        i++;
		goto endOfForLoop;
		break;
	}
    }
    endOfForLoop:
    if (objc - i < 1) {
        Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?");
	return TCL_ERROR;
    }
    if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) {
	Tcl_AppendToObj(resultPtr,
	  "\"-tails\" must be used with either \"-directory\" or \"-path\"",
	  -1);
	return TCL_ERROR;
    }
    
    separators = NULL;		/* lint. */
    switch (tclPlatform) {
	case TCL_PLATFORM_UNIX:
	    separators = "/";
	    break;
	case TCL_PLATFORM_WINDOWS:
	    separators = "/\\:";
	    break;
	case TCL_PLATFORM_MAC:
	    separators = ":";
	    break;
    }
    if (dir == PATH_GENERAL) {
	int pathlength;
	char *last;
	char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength);

	/*
	 * Find the last path separator in the path
	 */
	last = first + pathlength;
	for (; last != first; last--) {
	    if (strchr(separators, *(last-1)) != NULL) {
		break;
	    }
	}
	if (last == first + pathlength) {
	    /* It's really a directory */
	    dir = PATH_DIR;
	} else {
	    Tcl_DString pref;
	    char *search, *find;
	    Tcl_DStringInit(&pref);
	    if (last == first) {
		/* The whole thing is a prefix */
		Tcl_DStringAppend(&pref, first, -1);
		pathOrDir = NULL;
	    } else {
		/* Have to split off the end */
		Tcl_DStringAppend(&pref, last, first+pathlength-last);
		pathOrDir = Tcl_NewStringObj(first, last-first-1);
	    }
	    /* Need to quote 'prefix' */
	    Tcl_DStringInit(&prefix);
	    search = Tcl_DStringValue(&pref);
	    while ((find = (strpbrk(search, "\\[]*?{}"))) != NULL) {
	        Tcl_DStringAppend(&prefix, search, find-search);
	        Tcl_DStringAppend(&prefix, "\\", 1);
	        Tcl_DStringAppend(&prefix, find, 1);
	        search = find+1;
	        if (*search == '\0') {
	            break;
	        }
	    }
	    if (*search != '\0') {
		Tcl_DStringAppend(&prefix, search, -1);
	    }
	    Tcl_DStringFree(&pref);
	}
    }
    
    if (pathOrDir != NULL) {
	Tcl_IncrRefCount(pathOrDir);
    }
    
    if (typePtr != NULL) {
	/* 
	 * The rest of the possible type arguments (except 'd') are
	 * platform specific.  We don't complain when they are used
	 * on an incompatible platform.
	 */
	Tcl_ListObjLength(interp, typePtr, &length);
	globTypes = (Tcl_GlobTypeData*) ckalloc(sizeof(Tcl_GlobTypeData));
	globTypes->type = 0;
	globTypes->perm = 0;
	globTypes->macType = NULL;
	globTypes->macCreator = NULL;
	while(--length >= 0) {
	    int len;
	    char *str;
	    Tcl_ListObjIndex(interp, typePtr, length, &look);
	    str = Tcl_GetStringFromObj(look, &len);
	    if (strcmp("readonly", str) == 0) {
		globTypes->perm |= TCL_GLOB_PERM_RONLY;
	    } else if (strcmp("hidden", str) == 0) {
		globTypes->perm |= TCL_GLOB_PERM_HIDDEN;
	    } else if (len == 1) {
		switch (str[0]) {
		  case 'r':
		    globTypes->perm |= TCL_GLOB_PERM_R;
		    break;
		  case 'w':
		    globTypes->perm |= TCL_GLOB_PERM_W;
		    break;
		  case 'x':
		    globTypes->perm |= TCL_GLOB_PERM_X;
		    break;
		  case 'b':
		    globTypes->type |= TCL_GLOB_TYPE_BLOCK;
		    break;
		  case 'c':
		    globTypes->type |= TCL_GLOB_TYPE_CHAR;
		    break;
		  case 'd':
		    globTypes->type |= TCL_GLOB_TYPE_DIR;
		    break;
		  case 'p':
		    globTypes->type |= TCL_GLOB_TYPE_PIPE;
		    break;
		  case 'f':
		    globTypes->type |= TCL_GLOB_TYPE_FILE;
		    break;
	          case 'l':
		    globTypes->type |= TCL_GLOB_TYPE_LINK;
		    break;
		  case 's':
		    globTypes->type |= TCL_GLOB_TYPE_SOCK;
		    break;
		  default:
		    goto badTypesArg;
		}
	    } else if (len == 4) {
		/* This is assumed to be a MacOS file type */
		if (globTypes->macType != NULL) {
		    goto badMacTypesArg;
		}
		globTypes->macType = look;
		Tcl_IncrRefCount(look);
	    } else {
		Tcl_Obj* item;
		if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) &&
			(len == 3)) {
		    Tcl_ListObjIndex(interp, look, 0, &item);
		    if (!strcmp("macintosh", Tcl_GetString(item))) {
			Tcl_ListObjIndex(interp, look, 1, &item);
			if (!strcmp("type", Tcl_GetString(item))) {
			    Tcl_ListObjIndex(interp, look, 2, &item);
			    if (globTypes->macType != NULL) {
				goto badMacTypesArg;
			    }
			    globTypes->macType = item;
			    Tcl_IncrRefCount(item);
			    continue;
			} else if (!strcmp("creator", Tcl_GetString(item))) {
			    Tcl_ListObjIndex(interp, look, 2, &item);
			    if (globTypes->macCreator != NULL) {
				goto badMacTypesArg;
			    }
			    globTypes->macCreator = item;
			    Tcl_IncrRefCount(item);
			    continue;
			}
		    }
		}
		/*
		 * Error cases.  We re-get the interpreter's result,
		 * just to be sure it hasn't changed, and we reset
		 * the 'join' flag to zero, since we haven't yet
		 * made use of it.
		 */
		badTypesArg:
		resultPtr = Tcl_GetObjResult(interp);
		Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1);
		Tcl_AppendObjToObj(resultPtr, look);
		result = TCL_ERROR;
		join = 0;
		goto endOfGlob;
		badMacTypesArg:
		resultPtr = Tcl_GetObjResult(interp);
		Tcl_AppendToObj(resultPtr,
		   "only one MacOS type or creator argument"
		   " to \"-types\" allowed", -1);
		result = TCL_ERROR;
		join = 0;
		goto endOfGlob;
	    }
	}
    }

    /* 
     * Now we perform the actual glob below.  This may involve joining
     * together the pattern arguments, dealing with particular file types
     * etc.  We use a 'goto' to ensure we free any memory allocated along
     * the way.
     */
    objc -= i;
    objv += i;
    /* 
     * We re-retrieve this, in case it was changed in 
     * the Tcl_ResetResult above 
     */
    resultPtr = Tcl_GetObjResult(interp);
    result = TCL_OK;
    if (join) {
	if (dir != PATH_GENERAL) {
	    Tcl_DStringInit(&prefix);
	}
	for (i = 0; i < objc; i++) {
	    string = Tcl_GetStringFromObj(objv[i], &length);
	    Tcl_DStringAppend(&prefix, string, length);
	    if (i != objc -1) {
		Tcl_DStringAppend(&prefix, separators, 1);
	    }
	}
	if (TclGlob(interp, Tcl_DStringValue(&prefix), pathOrDir,
		globFlags, globTypes) != TCL_OK) {
	    result = TCL_ERROR;
	    goto endOfGlob;
	}
    } else {
	if (dir == PATH_GENERAL) {
	    Tcl_DString str;
	    for (i = 0; i < objc; i++) {
		Tcl_DStringInit(&str);
		if (dir == PATH_GENERAL) {
		    Tcl_DStringAppend(&str, Tcl_DStringValue(&prefix),
			    Tcl_DStringLength(&prefix));
		}
		string = Tcl_GetStringFromObj(objv[i], &length);
		Tcl_DStringAppend(&str, string, length);
		if (TclGlob(interp, Tcl_DStringValue(&str), pathOrDir,
			globFlags, globTypes) != TCL_OK) {
		    result = TCL_ERROR;
		    Tcl_DStringFree(&str);
		    goto endOfGlob;
		}
	    }
	    Tcl_DStringFree(&str);
	} else {
	    for (i = 0; i < objc; i++) {
		string = Tcl_GetString(objv[i]);
		if (TclGlob(interp, string, pathOrDir,
			globFlags, globTypes) != TCL_OK) {
		    result = TCL_ERROR;
		    goto endOfGlob;
		}
	    }
	}
    }
    if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) {
	if (Tcl_ListObjLength(interp, Tcl_GetObjResult(interp),
		&length) != TCL_OK) {
	    /* This should never happen.  Maybe we should be more dramatic */
	    result = TCL_ERROR;
	    goto endOfGlob;
	}
	if (length == 0) {
	    Tcl_AppendResult(interp, "no files matched glob pattern",
		    (join || (objc == 1)) ? " \"" : "s \"", (char *) NULL);
	    if (join) {
		Tcl_AppendResult(interp, Tcl_DStringValue(&prefix),
			(char *) NULL);
	    } else {
		char *sep = "";
		for (i = 0; i < objc; i++) {
		    string = Tcl_GetString(objv[i]);
		    Tcl_AppendResult(interp, sep, string, (char *) NULL);
		    sep = " ";
		}
	    }
	    Tcl_AppendResult(interp, "\"", (char *) NULL);
	    result = TCL_ERROR;
	}
    }
  endOfGlob:
    if (join || (dir == PATH_GENERAL)) {
	Tcl_DStringFree(&prefix);
    }
    if (pathOrDir != NULL) {
	Tcl_DecrRefCount(pathOrDir);
    }
    if (globTypes != NULL) {
	if (globTypes->macType != NULL) {
	    Tcl_DecrRefCount(globTypes->macType);
	}
	if (globTypes->macCreator != NULL) {
	    Tcl_DecrRefCount(globTypes->macCreator);
	}
	ckfree((char *) globTypes);
    }
    return result;
}

/*
 *----------------------------------------------------------------------
 *
 * TclGlob --
 *
 *	This procedure prepares arguments for the TclDoGlob call.
 *	It sets the separator string based on the platform, performs
 *      tilde substitution, and calls TclDoGlob.
 *      
 *      The interpreter's result, on entry to this function, must
 *      be a valid Tcl list (e.g. it could be empty), since we will
 *      lappend any new results to that list.  If it is not a valid
 *      list, this function will fail to do anything very meaningful.
 *
 * Results:
 *	The return value is a standard Tcl result indicating whether
 *	an error occurred in globbing.  After a normal return the
 *	result in interp (set by TclDoGlob) holds all of the file names
 *	given by the pattern and unquotedPrefix arguments.  After an 
 *	error the result in interp will hold an error message, unless
 *	the 'TCL_GLOBMODE_NO_COMPLAIN' flag was given, in which case
 *	an error results in a TCL_OK return leaving the interpreter's
 *	result unmodified.
 *
 * Side effects:
 *	The 'pattern' is written to.
 *
 *----------------------------------------------------------------------
 */

	/* ARGSUSED */
int