tclioutil.c

tcl是工具命令语言

     * Call each of the "access" function in succession.  A non-return
     * value of -1 indicates the particular function has succeeded.
     */

    Tcl_MutexLock(&obsoleteFsHookMutex);

    if (accessProcList != NULL) {
	AccessProc *accessProcPtr;
	char *path;
	Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
	if (transPtr == NULL) {
	    path = NULL;
	} else {
	    path = Tcl_GetString(transPtr);
	}

	accessProcPtr = accessProcList;
	while ((retVal == -1) && (accessProcPtr != NULL)) {
	    retVal = (*accessProcPtr->proc)(path, mode);
	    accessProcPtr = accessProcPtr->nextPtr;
	}
    }
    
    Tcl_MutexUnlock(&obsoleteFsHookMutex);
    if (retVal != -1) {
	return retVal;
    }
#endif /* USE_OBSOLETE_FS_HOOKS */
    fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSAccessProc *proc = fsPtr->accessProc;
	if (proc != NULL) {
	    return (*proc)(pathPtr, mode);
	}
    }

    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSOpenFileChannel --
 *
 *	The appropriate function for the filesystem to which pathPtr
 *	belongs will be called.
 *
 * Results:
 *	The new channel or NULL, if the named file could not be opened.
 *
 * Side effects:
 *	May open the channel and may cause creation of a file on the
 *	file system.
 *
 *----------------------------------------------------------------------
 */
 
Tcl_Channel
Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions)
    Tcl_Interp *interp;                 /* Interpreter for error reporting;
                                         * can be NULL. */
    Tcl_Obj *pathPtr;                   /* Name of file to open. */
    CONST char *modeString;             /* A list of POSIX open modes or
                                         * a string such as "rw". */
    int permissions;                    /* If the open involves creating a
                                         * file, with what modes to create
                                         * it? */
{
    Tcl_Filesystem *fsPtr;
#ifdef USE_OBSOLETE_FS_HOOKS
    OpenFileChannelProc *openFileChannelProcPtr;
    Tcl_Channel retVal = NULL;
    char *path;
#endif /* USE_OBSOLETE_FS_HOOKS */
    Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
    if (transPtr == NULL) {
	return NULL;
    }
#ifdef USE_OBSOLETE_FS_HOOKS
    if (transPtr == NULL) {
	path = NULL;
    } else {
	path = Tcl_GetString(transPtr);
    }

    /*
     * Call each of the "Tcl_OpenFileChannel" function in succession.
     * A non-NULL return value indicates the particular function has
     * succeeded.
     */

    Tcl_MutexLock(&obsoleteFsHookMutex);
    openFileChannelProcPtr = openFileChannelProcList;
    while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) {
	retVal = (*openFileChannelProcPtr->proc)(interp, path,
		modeString, permissions);
	openFileChannelProcPtr = openFileChannelProcPtr->nextPtr;
    }
    Tcl_MutexUnlock(&obsoleteFsHookMutex);
    if (retVal != NULL) {
	return retVal;
    }
#endif /* USE_OBSOLETE_FS_HOOKS */
    fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc;
	if (proc != NULL) {
	    int mode, seekFlag;
	    mode = TclGetOpenMode(interp, modeString, &seekFlag);
	    if (mode == -1) {
	        return NULL;
	    }
	    retVal = (*proc)(interp, pathPtr, mode, permissions);
	    if (retVal != NULL) {
		if (seekFlag) {
		    if (Tcl_Seek(retVal, (Tcl_WideInt)0, 
				 SEEK_END) < (Tcl_WideInt)0) {
			if (interp != (Tcl_Interp *) NULL) {
			    Tcl_AppendResult(interp,
			      "could not seek to end of file while opening \"",
			      Tcl_GetString(pathPtr), "\": ", 
			      Tcl_PosixError(interp), (char *) NULL);
			}
			Tcl_Close(NULL, retVal);
			return NULL;
		    }
		}
	    }
	    return retVal;
	}
    }
    /* File doesn't belong to any filesystem that can open it */
    Tcl_SetErrno(ENOENT);
    if (interp != NULL) {
	Tcl_AppendResult(interp, "couldn't open \"", 
			 Tcl_GetString(pathPtr), "\": ",
			 Tcl_PosixError(interp), (char *) NULL);
    }
    return NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSMatchInDirectory --
 *
 *	This routine is used by the globbing code to search a directory
 *	for all files which match a given pattern.  The appropriate
 *	function for the filesystem to which pathPtr belongs will be
 *	called.  If pathPtr does not belong to any filesystem and if it
 *	is NULL or the empty string, then we assume the pattern is to be
 *	matched in the current working directory.  To avoid each
 *	filesystem's Tcl_FSMatchInDirectoryProc having to deal with this
 *	issue, we create a pathPtr on the fly (equal to the cwd), and
 *	then remove it from the results returned.  This makes filesystems
 *	easy to write, since they can assume the pathPtr passed to them
 *	is an ordinary path.  In fact this means we could remove such
 *	special case handling from Tcl's native filesystems.
 *	
 *	If 'pattern' is NULL, then pathPtr is assumed to be a fully
 *	specified path of a single file/directory which must be
 *	checked for existence and correct type.
 *
 * Results: 
 *	
 *	The return value is a standard Tcl result indicating whether an
 *	error occurred in globbing.  Error messages are placed in
 *	interp, but good results are placed in the resultPtr given.
 *	
 *	Recursive searches, e.g.
 *	
 *	   glob -dir $dir -join * pkgIndex.tcl
 *	   
 *	which must recurse through each directory matching '*' are
 *	handled internally by Tcl, by passing specific flags in a 
 *	modified 'types' parameter.  This means the actual filesystem
 *	only ever sees patterns which match in a single directory.
 *
 * Side effects:
 *	The interpreter may have an error message inserted into it.
 *
 *---------------------------------------------------------------------- 
 */

int
Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types)
    Tcl_Interp *interp;		/* Interpreter to receive error messages. */
    Tcl_Obj *result;		/* List object to receive results. */
    Tcl_Obj *pathPtr;	        /* Contains path to directory to search. */
    CONST char *pattern;	/* Pattern to match against. */
    Tcl_GlobTypeData *types;	/* Object containing list of acceptable types.
				 * May be NULL. In particular the directory
				 * flag is very important. */
{
    Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
    if (fsPtr != NULL) {
	Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc;
	if (proc != NULL) {
	    return (*proc)(interp, result, pathPtr, pattern, types);
	}
    } else {
	Tcl_Obj* cwd;
	int ret = -1;
	if (pathPtr != NULL) {
	    int len;
	    Tcl_GetStringFromObj(pathPtr,&len);
	    if (len != 0) {
		/* 
		 * We have no idea how to match files in a directory
		 * which belongs to no known filesystem
		 */
		Tcl_SetErrno(ENOENT);
		return -1;
	    }
	}
	/* 
	 * We have an empty or NULL path.  This is defined to mean we
	 * must search for files within the current 'cwd'.  We
	 * therefore use that, but then since the proc we call will
	 * return results which include the cwd we must then trim it
	 * off the front of each path in the result.  We choose to deal
	 * with this here (in the generic code), since if we don't,
	 * every single filesystem's implementation of
	 * Tcl_FSMatchInDirectory will have to deal with it for us.
	 */
	cwd = Tcl_FSGetCwd(NULL);
	if (cwd == NULL) {
	    if (interp != NULL) {
	        Tcl_SetResult(interp, "glob couldn't determine "
			  "the current working directory", TCL_STATIC);
	    }
	    return TCL_ERROR;
	}
	fsPtr = Tcl_FSGetFileSystemForPath(cwd);
	if (fsPtr != NULL) {
	    Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc;
	    if (proc != NULL) {
		int cwdLen;
		char *cwdStr;
		Tcl_Obj* tmpResultPtr = Tcl_NewListObj(0, NULL);
		Tcl_IncrRefCount(tmpResultPtr);
		/* 
		 * We know the cwd is a normalised object which does
		 * not end in a directory delimiter, unless the cwd
		 * is the name of a volume, in which case it will
		 * end in a delimiter!  We handle this situation here.
		 * A better test than the '!= sep' might be to simply
		 * check if 'cwd' is a root volume.
		 * 
		 * Note that if we get this wrong, we will strip off
		 * either too much or too little below, leading to
		 * wrong answers returned by glob.
		 */
		cwdStr = Tcl_GetStringFromObj(cwd, &cwdLen);
		/* 
		 * Should we perhaps use 'Tcl_FSPathSeparator'?
		 * But then what about the Windows special case?
		 * Perhaps we should just check if cwd is a root
		 * volume.
		 */
		switch (tclPlatform) {
		    case TCL_PLATFORM_UNIX:
			if (cwdStr[cwdLen-1] != '/') {
			    cwdLen++;
			}
			break;
		    case TCL_PLATFORM_WINDOWS:
			if (cwdStr[cwdLen-1] != '/' 
				&& cwdStr[cwdLen-1] != '\\') {
			    cwdLen++;
			}
			break;
		    case TCL_PLATFORM_MAC:
			if (cwdStr[cwdLen-1] != ':') {
			    cwdLen++;
			}
			break;
		}
		ret = (*proc)(interp, tmpResultPtr, cwd, pattern, types);
		if (ret == TCL_OK) {
		    int resLength;

		    ret = Tcl_ListObjLength(interp, tmpResultPtr, &resLength);
		    if (ret == TCL_OK) {
			int i;

			for (i = 0; i < resLength; i++) {
			    Tcl_Obj *cutElt, *elt;
			    char *eltStr;
			    int eltLen;
			    
			    Tcl_ListObjIndex(interp, tmpResultPtr, i, &elt);
			    if (elt->typePtr == &tclFsPathType) {
				FsPath* fsPathPtr = (FsPath*) 
				                elt->internalRep.otherValuePtr;
				if (fsPathPtr->flags != 0 
					&& fsPathPtr->cwdPtr == cwd) {
				    Tcl_ListObjAppendElement(interp, result, 
					MakeFsPathFromRelative(interp, 
						fsPathPtr->normPathPtr, cwd));
				    continue;
				}
			    }
			    eltStr = Tcl_GetStringFromObj(elt, &eltLen);
			    cutElt = Tcl_NewStringObj(eltStr + cwdLen,
				    eltLen - cwdLen);
			    Tcl_ListObjAppendElement(interp, result, cutElt);
			}
		    }
		}
		Tcl_DecrRefCount(tmpResultPtr);
	    }
	}
	Tcl_DecrRefCount(cwd);
	return ret;
    }
    Tcl_SetErrno(ENOENT);
    return -1;
}

/*
 *----------------------------------------------------------------------
 *
 * Tcl_FSGetCwd --
 *
 *	This function replaces the library version of getcwd().
 *	
 *	Most VFS's will *not* implement a 'cwdProc'.  Tcl now maintains
 *	its own record (in a Tcl_Obj) of the cwd, and an attempt
 *	is made to synchronise this with the cwd's containing filesystem,
 *	if that filesystem provides a cwdProc (e.g. the native filesystem).
 *	
 *	Note that if Tcl's cwd is not in the native filesystem, then of
 *	course Tcl's cwd and the native cwd are different: extensions
 *	should therefore ensure they only access the cwd through this
 *	function to avoid confusion.
 *	
 *	If a global cwdPathPtr already exists, it is returned, subject
 *	to a synchronisation attempt in that cwdPathPtr's fs.
 *	Otherwise, the chain of functions that have been "inserted"
 *	into the filesystem will be called in succession until either a
 *	value other than NULL is returned, or the entire list is
 *	visited.
 *
 * Results:
 *	The result is a pointer to a Tcl_Obj specifying the current
 *	directory, or NULL if the current directory could not be
 *	determined.  If NULL is returned, an error message is left in the
 *	interp's result.  
 *	
 *	The result already has its refCount incremented for the caller.
 *	When it is no longer needed, that refCount should be decremented.
 *	This is needed for thread-safety purposes, to allow multiple
 *	threads to access this and related functions, while ensuring the
 *	results are always valid.
 *	
 *	Of course it is probably a bad idea for multiple threads to
 *	be *setting* the cwd anyway, but we can at least try to 
 *	help the case of multiple reads with occasional sets.
 *
 * Side effects:
 *	Various objects may be freed and allocated.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj*
Tcl_FSGetCwd(interp)
    Tcl_Interp *interp;
{
    Tcl_Obj *cwdToReturn;
    
    if (FsCwdPointerEquals(NULL)) {
	FilesystemRecord *fsRecPtr;
	Tcl_Obj *retVal = NULL;

        /* 
         * We've never been called before, try to find a cwd.  Call
         * each of the "Tcl_GetCwd" function in succession.  A non-NULL
         * return value indicates the particular function has
         * succeeded.
	 */

	fsRecPtr = FsGetIterator();
	while ((retVal == NULL) && (fsRecPtr != NULL)) {
	    Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc;
	    if (proc != NULL) {
		retVal = (*proc)(interp);
	    }
	    fsRecPtr = fsRecPtr->nextPtr;
	}
	FsReleaseIterator();
	/* 
	 * Now the 'cwd' may NOT be normalized, at least on some
	 * platforms.  For the sake of efficiency, we want a completely
	 * normalized cwd at all times.
	 * 
	 * Finally, if retVal is NULL, we do not have a cwd, which
	 * could be problematic.
	 */
	if (retVal != NULL) {
	    Tcl_Obj *norm = FSNormalizeAbsolutePath(interp, retVal);
	    if (norm != NULL) {
		/* 
		 * We found a cwd, which is now in our global storage.
		 * We must make a copy.  Norm already has a refCount of
		 * 1.
		 * 
		 * Threading issue: note that multiple threads at system
		 * startup could in principle call this procedure 
		 * simultaneously.  They will therefore each set the
		 * cwdPathPtr independently.  That behaviour is a bit
		 * peculiar, but should be fine.  Once we have a cwd,
		 * we'll always be in the 'else' branch below which
		 * is simpler.
		 */
		Tcl_MutexLock(&cwdMutex);
		/* Just in case the pointer has been set by another
		 * thread between now and the test above */
		if (cwd