tclcmdah.c

来自「tcl是工具命令语言」· C语言 代码 · 共 2,394 行 · 第 1/5 页

	    Tcl_Obj *contents;
	    int index;
	    
	    if (objc < 3 || objc > 5) {
		Tcl_WrongNumArgs(interp, 2, objv, 
				 "?-linktype? linkname ?target?");
		return TCL_ERROR;
	    }
	    
	    /* Index of the 'source' argument */
	    if (objc == 5) {
		index = 3;
	    } else {
		index = 2;
	    }
	    
	    if (objc > 3) {
		int linkAction;
		if (objc == 5) {
		    /* We have a '-linktype' argument */
		    static CONST char *linkTypes[] = {
			"-symbolic", "-hard", NULL
		    };
		    if (Tcl_GetIndexFromObj(interp, objv[2], linkTypes, 
				     "switch", 0, &linkAction) != TCL_OK) {
			return TCL_ERROR;
		    }
		    if (linkAction == 0) {
		        linkAction = TCL_CREATE_SYMBOLIC_LINK;
		    } else {
			linkAction = TCL_CREATE_HARD_LINK;
		    }
		} else {
		    linkAction = TCL_CREATE_SYMBOLIC_LINK|TCL_CREATE_HARD_LINK;
		}
		if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
		    return TCL_ERROR;
		}
		/* Create link from source to target */
		contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
		if (contents == NULL) {
		    /* 
		     * We handle two common error cases specially, and
		     * for all other errors, we use the standard posix
		     * error message.
		     */
		    if (errno == EEXIST) {
			Tcl_AppendResult(interp, "could not create new link \"", 
				Tcl_GetString(objv[index]), 
				"\": that path already exists", (char *) NULL);
		    } else if (errno == ENOENT) {
			Tcl_AppendResult(interp, "could not create new link \"", 
				Tcl_GetString(objv[index]), 
				"\" since target \"", 
				Tcl_GetString(objv[index+1]), 
				"\" doesn't exist", 
				(char *) NULL);
		    } else {
			Tcl_AppendResult(interp, "could not create new link \"", 
				Tcl_GetString(objv[index]), "\" pointing to \"", 
				Tcl_GetString(objv[index+1]), "\": ", 
				Tcl_PosixError(interp), (char *) NULL);
		    }
		    return TCL_ERROR;
		}
	    } else {
		if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
		    return TCL_ERROR;
		}
		/* Read link */
		contents = Tcl_FSLink(objv[index], NULL, 0);
		if (contents == NULL) {
		    Tcl_AppendResult(interp, "could not read link \"", 
			    Tcl_GetString(objv[index]), "\": ", 
			    Tcl_PosixError(interp), (char *) NULL);
		    return TCL_ERROR;
		}
	    }
	    Tcl_SetObjResult(interp, contents);
	    if (objc == 3) {
		/* 
		 * If we are reading a link, we need to free this
		 * result refCount.  If we are creating a link, this
		 * will just be objv[index+1], and so we don't own it.
		 */
		Tcl_DecrRefCount(contents);
	    }
	    return TCL_OK;
	}
    	case FILE_LSTAT: {
	    char *varName;
	    Tcl_StatBuf buf;

    	    if (objc != 4) {
    	    	Tcl_WrongNumArgs(interp, 2, objv, "name varName");
    	    	return TCL_ERROR;
    	    }
	    if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
		return TCL_ERROR;
	    }
	    varName = Tcl_GetString(objv[3]);
	    return StoreStatData(interp, varName, &buf);
	}
	case FILE_MTIME: {
	    Tcl_StatBuf buf;
	    struct utimbuf tval;

	    if ((objc < 3) || (objc > 4)) {
		Tcl_WrongNumArgs(interp, 2, objv, "name ?time?");
		return TCL_ERROR;
	    }
	    if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (objc == 4) {
		if (Tcl_GetLongFromObj(interp, objv[3],
			(long*)(&buf.st_mtime)) != TCL_OK) {
		    return TCL_ERROR;
		}
		tval.actime = buf.st_atime;
		tval.modtime = buf.st_mtime;
		if (Tcl_FSUtime(objv[2], &tval) != 0) {
		    Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
			    "could not set modification time for file \"",
			    Tcl_GetString(objv[2]), "\": ",
			    Tcl_PosixError(interp), (char *) NULL);
		    return TCL_ERROR;
		}
		/*
		 * Do another stat to ensure that the we return the
		 * new recognized atime - hopefully the same as the
		 * one we sent in.  However, fs's like FAT don't
		 * even know what atime is.
		 */
		if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
		    return TCL_ERROR;
		}
	    }
	    Tcl_SetLongObj(Tcl_GetObjResult(interp), (long) buf.st_mtime);
	    return TCL_OK;
	}
	case FILE_MKDIR: {
	    if (objc < 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "name ?name ...?");
		return TCL_ERROR;
	    }
	    return TclFileMakeDirsCmd(interp, objc, objv);
	}
	case FILE_NATIVENAME: {
	    CONST char *fileName;
	    Tcl_DString ds;

	    if (objc != 3) {
		goto only3Args;
	    }
	    fileName = Tcl_GetString(objv[2]);
	    fileName = Tcl_TranslateFileName(interp, fileName, &ds);
	    if (fileName == NULL) {
		return TCL_ERROR;
	    }
	    Tcl_SetStringObj(Tcl_GetObjResult(interp), fileName, 
			     Tcl_DStringLength(&ds));
	    Tcl_DStringFree(&ds);
	    return TCL_OK;
	}
	case FILE_NORMALIZE: {
	    Tcl_Obj *fileName;

	    if (objc != 3) {
		Tcl_WrongNumArgs(interp, 2, objv, "filename");
		return TCL_ERROR;
	    }

	    fileName = Tcl_FSGetNormalizedPath(interp, objv[2]);
	    Tcl_SetObjResult(interp, fileName);
	    return TCL_OK;
	}
	case FILE_OWNED: {
	    int value;
	    Tcl_StatBuf buf;
	    
	    if (objc != 3) {
		goto only3Args;
	    }
	    value = 0;
	    if (GetStatBuf(NULL, objv[2], Tcl_FSStat, &buf) == TCL_OK) {
		/*
		 * For Windows and Macintosh, there are no user ids 
		 * associated with a file, so we always return 1.
		 */

#if (defined(__WIN32__) || defined(MAC_TCL))
		value = 1;
#else
		value = (geteuid() == buf.st_uid);
#endif
	    }	    
	    Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
	    return TCL_OK;
	}
	case FILE_PATHTYPE: {
	    if (objc != 3) {
		goto only3Args;
	    }
	    switch (Tcl_FSGetPathType(objv[2])) {
	    	case TCL_PATH_ABSOLUTE:
	    	    Tcl_SetStringObj(Tcl_GetObjResult(interp), "absolute", -1);
		    break;
	    	case TCL_PATH_RELATIVE:
	    	    Tcl_SetStringObj(Tcl_GetObjResult(interp), "relative", -1);
	    	    break;
	    	case TCL_PATH_VOLUME_RELATIVE:
		    Tcl_SetStringObj(Tcl_GetObjResult(interp), 
				     "volumerelative", -1);
		    break;
	    }
	    return TCL_OK;
	}
    	case FILE_READABLE: {
	    if (objc != 3) {
		goto only3Args;
	    }
	    return CheckAccess(interp, objv[2], R_OK);
	}
	case FILE_READLINK: {
	    Tcl_Obj *contents;
		
	    if (objc != 3) {
		goto only3Args;
	    }
	    
	    if (Tcl_FSConvertToPathType(interp, objv[2]) != TCL_OK) {
		return TCL_ERROR;
	    }

	    contents = Tcl_FSLink(objv[2], NULL, 0);

	    if (contents == NULL) {
	    	Tcl_AppendResult(interp, "could not readlink \"", 
	    		Tcl_GetString(objv[2]), "\": ", 
	    		Tcl_PosixError(interp), (char *) NULL);
	    	return TCL_ERROR;
	    }
	    Tcl_SetObjResult(interp, contents);
	    Tcl_DecrRefCount(contents);
	    return TCL_OK;
	}
	case FILE_RENAME: {
	    return TclFileRenameCmd(interp, objc, objv);
	}
	case FILE_ROOTNAME: {
	    int length;
	    char *fileName, *extension;
	    
	    if (objc != 3) {
		goto only3Args;
	    }
	    fileName = Tcl_GetStringFromObj(objv[2], &length);
	    extension = TclGetExtension(fileName);
	    if (extension == NULL) {
	    	Tcl_SetObjResult(interp, objv[2]);
	    } else {
	        Tcl_SetStringObj(Tcl_GetObjResult(interp), fileName,
			(int) (length - strlen(extension)));
	    }
	    return TCL_OK;
	}
	case FILE_SEPARATOR: {
	    if ((objc < 2) || (objc > 3)) {
		Tcl_WrongNumArgs(interp, 2, objv, "?name?");
		return TCL_ERROR;
	    }
	    if (objc == 2) {
	        char *separator = NULL; /* lint */
		switch (tclPlatform) {
		    case TCL_PLATFORM_UNIX:
			separator = "/";
			break;
		    case TCL_PLATFORM_WINDOWS:
			separator = "\\";
			break;
		    case TCL_PLATFORM_MAC:
			separator = ":";
			break;
		}
		Tcl_SetObjResult(interp, Tcl_NewStringObj(separator,1));
	    } else {
		Tcl_Obj *separatorObj = Tcl_FSPathSeparator(objv[2]);
		if (separatorObj != NULL) {
		    Tcl_SetObjResult(interp, separatorObj);
		} else {
		    Tcl_SetObjResult(interp, 
			    Tcl_NewStringObj("Unrecognised path",-1));
		    return TCL_ERROR;
		}
	    }
	    return TCL_OK;
	}
	case FILE_SIZE: {
	    Tcl_StatBuf buf;
	    
	    if (objc != 3) {
		goto only3Args;
	    }
	    if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
		return TCL_ERROR;
	    }
	    Tcl_SetWideIntObj(Tcl_GetObjResult(interp),
		    (Tcl_WideInt) buf.st_size);
	    return TCL_OK;
	}
	case FILE_SPLIT: {
	    if (objc != 3) {
		goto only3Args;
	    }
	    Tcl_SetObjResult(interp, Tcl_FSSplitPath(objv[2], NULL));
	    return TCL_OK;
	}
	case FILE_STAT: {
	    char *varName;
	    Tcl_StatBuf buf;
	    
	    if (objc != 4) {
	    	Tcl_WrongNumArgs(interp, 1, objv, "stat name varName");
		return TCL_ERROR;
	    }
	    if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
		return TCL_ERROR;
	    }
	    varName = Tcl_GetString(objv[3]);
	    return StoreStatData(interp, varName, &buf);
	}
	case FILE_SYSTEM: {
	    Tcl_Obj* fsInfo;
	    if (objc != 3) {
		goto only3Args;
	    }
	    fsInfo = Tcl_FSFileSystemInfo(objv[2]);
	    if (fsInfo != NULL) {
		Tcl_SetObjResult(interp, fsInfo);
		return TCL_OK;
	    } else {
		Tcl_SetObjResult(interp, 
				 Tcl_NewStringObj("Unrecognised path",-1));
		return TCL_ERROR;
	    }
	}
    	case FILE_TAIL: {
	    int splitElements;
	    Tcl_Obj *splitPtr;

	    if (objc != 3) {
		goto only3Args;
	    }
	    /* 
	     * The behaviour we want here is slightly different to
	     * the standard Tcl_FSSplitPath in the handling of home
	     * directories; Tcl_FSSplitPath preserves the "~" while 
	     * this code computes the actual full path name, if we
	     * had just a single component.
	     */	    
	    splitPtr = Tcl_FSSplitPath(objv[2], &splitElements);
	    if ((splitElements == 1) && (Tcl_GetString(objv[2])[0] == '~')) {
		Tcl_DecrRefCount(splitPtr);
		splitPtr = Tcl_FSGetNormalizedPath(interp, objv[2]);
		if (splitPtr == NULL) {
		    return TCL_ERROR;
		}
		splitPtr = Tcl_FSSplitPath(splitPtr, &splitElements);
	    }

	    /*
	     * Return the last component, unless it is the only component,
	     * and it is the root of an absolute path.
	     */

	    if (splitElements > 0) {
	    	if ((splitElements > 1)
		  || (Tcl_FSGetPathType(objv[2]) == TCL_PATH_RELATIVE)) {
		    
		    Tcl_Obj *tail = NULL;
		    Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &tail);
		    Tcl_SetObjResult(interp, tail);
	    	}
	    }
	    Tcl_DecrRefCount(splitPtr);
	    return TCL_OK;
	}
	case FILE_TYPE: {
	    Tcl_StatBuf buf;

	    if (objc != 3) {
	    	goto only3Args;
	    }
	    if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
		return TCL_ERROR;
	    }
	    Tcl_SetStringObj(Tcl_GetObjResult(interp), 
		    GetTypeFromMode((unsigned short) buf.st_mode), -1);
	    return TCL_OK;
	}
	case FILE_VOLUMES: {
	    if (objc != 2) {
		Tcl_WrongNumArgs(interp, 2, objv, NULL);
		return TCL_ERROR;
	    }
	    Tcl_SetObjResult(interp, Tcl_FSListVolumes());
	    return TCL_OK;
	}
	case FILE_WRITABLE: {
	    if (objc != 3) {
	    	goto only3Args;
	    }
	    return CheckAccess(interp, objv[2], W_OK);
	}
    }

    only3Args:
    Tcl_WrongNumArgs(interp, 2, objv, "name");
    return TCL_ERROR;
}

/*
 *---------------------------------------------------------------------------
 *
 * CheckAccess --
 *
 *	Utility procedure used by Tcl_FileObjCmd() to query file
 *	attributes available through the access() system call.
 *
 * Results:
 *	Always returns TCL_OK.  Sets interp's result to boolean true or
 *	false depending on whether the file has the specified attribute.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */
  
static int
CheckAccess(interp, objPtr, mode)
    Tcl_Interp *interp;		/* Interp for status return.  Must not be
				 * NULL. */
    Tcl_Obj *objPtr;		/* Name of file to check. */
    int mode;			/* Attribute to check; passed as argument to
				 * access(). */
{
    int value;
    
    if (Tcl_FSConvertToPathType(interp, objPtr) != TCL_OK) {
	value = 0;
    } else {
	value = (Tcl_FSAccess(objPtr, mode) == 0);
    }
    Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);

    return TCL_OK;
}

/*
 *---------------------------------------------------------------------------
 *
 * GetStatBuf --
 *
 *	Utility procedure used by Tcl_FileObjCmd() to query file
 *	attributes available through the stat() or lstat() system call.
 *
 * Results:
 *	The return value is TCL_OK if the specified file exists and can
 *	be stat'ed, TCL_ERROR otherwise.  If TCL_ERROR is returned, an
 *	error message is left in interp's result.  If TCL_OK is returned,
 *	*statPtr is filled with information about the specified file.
 *
 * Side effects:
 *	None.
 *
 *---------------------------------------------------------------------------
 */