int TclFileReadLinkCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Obj *contents; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "name"); return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { return TCL_ERROR; } contents = Tcl_FSLink(objv[1], NULL, 0); if (contents == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not read link \"%s\": %s", TclGetString(objv[1]), Tcl_PosixError(interp))); return TCL_ERROR; } Tcl_SetObjResult(interp, contents); Tcl_DecrRefCount(contents); return TCL_OK; }
static Tcl_Obj * FileBasename( Tcl_Interp *interp, /* Interp, for error return. */ Tcl_Obj *pathPtr) /* Path whose basename to extract. */ { int objc; Tcl_Obj *splitPtr; Tcl_Obj *resultPtr = NULL; splitPtr = Tcl_FSSplitPath(pathPtr, &objc); Tcl_IncrRefCount(splitPtr); if (objc != 0) { if ((objc == 1) && (*TclGetString(pathPtr) == '~')) { Tcl_DecrRefCount(splitPtr); if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { return NULL; } splitPtr = Tcl_FSSplitPath(pathPtr, &objc); Tcl_IncrRefCount(splitPtr); } /* * Return the last component, unless it is the only component, and it * is the root of an absolute path. */ if (objc > 0) { Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr); if ((objc == 1) && (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) { resultPtr = NULL; } } } if (resultPtr == NULL) { resultPtr = Tcl_NewObj(); } Tcl_IncrRefCount(resultPtr); Tcl_DecrRefCount(splitPtr); return resultPtr; }
int TclFileAttrsCmd( ClientData clientData, /* Unused */ Tcl_Interp *interp, /* The interpreter for error reporting. */ int objc, /* Number of command line arguments. */ Tcl_Obj *const objv[]) /* The command line objects. */ { int result; const char *const *attributeStrings; const char **attributeStringsAllocated = NULL; Tcl_Obj *objStrings = NULL; int numObjStrings = -1; Tcl_Obj *filePtr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "name ?-option value ...?"); return TCL_ERROR; } filePtr = objv[1]; if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) { return TCL_ERROR; } objc -= 2; objv += 2; result = TCL_ERROR; Tcl_SetErrno(0); /* * Get the set of attribute names from the filesystem. */ attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings); if (attributeStrings == NULL) { int index; Tcl_Obj *objPtr; if (objStrings == NULL) { if (Tcl_GetErrno() != 0) { /* * There was an error, probably that the filePtr is not * accepted by any filesystem */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not read \"%s\": %s", TclGetString(filePtr), Tcl_PosixError(interp))); } return TCL_ERROR; } /* * We own the object now. */ Tcl_IncrRefCount(objStrings); /* * Use objStrings as a list object. */ if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) { goto end; } attributeStringsAllocated = (const char **) TclStackAlloc(interp, (1+numObjStrings) * sizeof(char *)); for (index = 0; index < numObjStrings; index++) { Tcl_ListObjIndex(interp, objStrings, index, &objPtr); attributeStringsAllocated[index] = TclGetString(objPtr); } attributeStringsAllocated[index] = NULL; attributeStrings = attributeStringsAllocated; } else if (objStrings != NULL) { Tcl_Panic("must not update objPtrRef's variable and return non-NULL"); } /* * Process the attributes to produce a list of all of them, the value of a * particular attribute, or to set one or more attributes (depending on * the number of arguments). */ if (objc == 0) { /* * Get all attributes. */ int index, res = TCL_OK, nbAtts = 0; Tcl_Obj *listPtr; listPtr = Tcl_NewListObj(0, NULL); for (index = 0; attributeStrings[index] != NULL; index++) { Tcl_Obj *objPtrAttr; if (res != TCL_OK) { /* * Clear the error from the last iteration. */ Tcl_ResetResult(interp); } res = Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtrAttr); if (res == TCL_OK) { Tcl_Obj *objPtr = Tcl_NewStringObj(attributeStrings[index], -1); Tcl_ListObjAppendElement(interp, listPtr, objPtr); Tcl_ListObjAppendElement(interp, listPtr, objPtrAttr); nbAtts++; } } if (index > 0 && nbAtts == 0) { /* * Error: no valid attributes found. */ Tcl_DecrRefCount(listPtr); goto end; } Tcl_SetObjResult(interp, listPtr); } else if (objc == 1) { /* * Get one attribute. */ int index; Tcl_Obj *objPtr = NULL; if (numObjStrings == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad option \"%s\", there are no file attributes in this" " filesystem", TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL); goto end; } if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings, "option", INDEX_TEMP_TABLE, &index) != TCL_OK) { goto end; } if (Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtr) != TCL_OK) { goto end; } Tcl_SetObjResult(interp, objPtr); } else { /* * Set option/value pairs. */ int i, index; if (numObjStrings == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad option \"%s\", there are no file attributes in this" " filesystem", TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL); goto end; } for (i = 0; i < objc ; i += 2) { if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings, "option", INDEX_TEMP_TABLE, &index) != TCL_OK) { goto end; } if (i + 1 == objc) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FATTR", "NOVALUE", NULL); goto end; } if (Tcl_FSFileAttrsSet(interp, index, filePtr, objv[i + 1]) != TCL_OK) { goto end; } } } result = TCL_OK; /* * Free up the array we allocated and drop our reference to any list of * attribute names issued by the filesystem. */ end: if (attributeStringsAllocated != NULL) { TclStackFree(interp, (void *) attributeStringsAllocated); } if (objStrings != NULL) { Tcl_DecrRefCount(objStrings); } return result; }
static int CopyRenameOneFile( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Obj *source, /* Pathname of file to copy. May need to be * translated. */ Tcl_Obj *target, /* Pathname of file to create/overwrite. May * need to be translated. */ int copyFlag, /* If non-zero, copy files. Otherwise, rename * them. */ int force) /* If non-zero, overwrite target file if it * exists. Otherwise, error if target already * exists. */ { int result; Tcl_Obj *errfile, *errorBuffer; Tcl_Obj *actualSource=NULL; /* If source is a link, then this is the real * file/directory. */ Tcl_StatBuf sourceStatBuf, targetStatBuf; if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) { return TCL_ERROR; } if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) { return TCL_ERROR; } errfile = NULL; errorBuffer = NULL; result = TCL_ERROR; /* * We want to copy/rename links and not the files they point to, so we use * lstat(). If target is a link, we also want to replace the link and not * the file it points to, so we also use lstat() on the target. */ if (Tcl_FSLstat(source, &sourceStatBuf) != 0) { errfile = source; goto done; } if (Tcl_FSLstat(target, &targetStatBuf) != 0) { if (errno != ENOENT) { errfile = target; goto done; } } else { if (force == 0) { errno = EEXIST; errfile = target; goto done; } /* * Prevent copying or renaming a file onto itself. On Windows since * 8.5 we do get an inode number, however the unsigned short field is * insufficient to accept the Win32 API file id so it is truncated to * 16 bits and we get collisions. See bug #2015723. */ #if !defined(_WIN32) && !defined(__CYGWIN__) if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) { if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) && (sourceStatBuf.st_dev == targetStatBuf.st_dev)) { result = TCL_OK; goto done; } } #endif /* * Prevent copying/renaming a file onto a directory and vice-versa. * This is a policy decision based on the fact that existing * implementations of copy and rename on all platforms also prevent * this. */ if (S_ISDIR(sourceStatBuf.st_mode) && !S_ISDIR(targetStatBuf.st_mode)) { errno = EISDIR; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't overwrite file \"%s\" with directory \"%s\"", TclGetString(target), TclGetString(source))); goto done; } if (!S_ISDIR(sourceStatBuf.st_mode) && S_ISDIR(targetStatBuf.st_mode)) { errno = EISDIR; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't overwrite directory \"%s\" with file \"%s\"", TclGetString(target), TclGetString(source))); goto done; } /* * The destination exists, but appears to be ok to over-write, and * -force is given. We now try to adjust permissions to ensure the * operation succeeds. If we can't adjust permissions, we'll let the * actual copy/rename return an error later. */ { Tcl_Obj *perm; int index; TclNewLiteralStringObj(perm, "u+w"); Tcl_IncrRefCount(perm); if (TclFSFileAttrIndex(target, "-permissions", &index) == TCL_OK) { Tcl_FSFileAttrsSet(NULL, index, target, perm); } Tcl_DecrRefCount(perm); } } if (copyFlag == 0) { result = Tcl_FSRenameFile(source, target); if (result == TCL_OK) { goto done; } if (errno == EINVAL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "error renaming \"%s\" to \"%s\": trying to rename a" " volume or move a directory into itself", TclGetString(source), TclGetString(target))); goto done; } else if (errno != EXDEV) { errfile = target; goto done; } /* * The rename failed because the move was across file systems. Fall * through to copy file and then remove original. Note that the * low-level Tcl_FSRenameFileProc in the filesystem is allowed to * implement cross-filesystem moves itself, if it desires. */ } actualSource = source; Tcl_IncrRefCount(actualSource); /* * Activate the following block to copy files instead of links. However * Tcl's semantics currently say we should copy links, so any such change * should be the subject of careful study on the consequences. * * Perhaps there could be an optional flag to 'file copy' to dictate which * approach to use, with the default being _not_ to have this block * active. */ #if 0 #ifdef S_ISLNK if (copyFlag && S_ISLNK(sourceStatBuf.st_mode)) { /* * We want to copy files not links. Therefore we must follow the link. * There are two purposes to this 'stat' call here. First we want to * know if the linked-file/dir actually exists, and second, in the * block of code which follows, some 20 lines down, we want to check * if the thing is a file or directory. */ if (Tcl_FSStat(source, &sourceStatBuf) != 0) { /* * Actual file doesn't exist. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "error copying \"%s\": the target of this link doesn't" " exist", TclGetString(source))); goto done; } else { int counter = 0; while (1) { Tcl_Obj *path = Tcl_FSLink(actualSource, NULL, 0); if (path == NULL) { break; } /* * Now we want to check if this is a relative path, and if so, * to make it absolute. */ if (Tcl_FSGetPathType(path) == TCL_PATH_RELATIVE) { Tcl_Obj *abs = Tcl_FSJoinToPath(actualSource, 1, &path); if (abs == NULL) { break; } Tcl_IncrRefCount(abs); Tcl_DecrRefCount(path); path = abs; } Tcl_DecrRefCount(actualSource); actualSource = path; counter++; /* * Arbitrary limit of 20 links to follow. */ if (counter > 20) { /* * Too many links. */ Tcl_SetErrno(EMLINK); errfile = source; goto done; } } /* Now 'actualSource' is the correct file */ } } #endif /* S_ISLNK */ #endif if (S_ISDIR(sourceStatBuf.st_mode)) { result = Tcl_FSCopyDirectory(actualSource, target, &errorBuffer); if (result != TCL_OK) { if (errno == EXDEV) { /* * The copy failed because we're trying to do a * cross-filesystem copy. We do this through our Tcl library. */ Tcl_Obj *copyCommand, *cmdObj, *opObj; TclNewObj(copyCommand); TclNewLiteralStringObj(cmdObj, "::tcl::CopyDirectory"); Tcl_ListObjAppendElement(interp, copyCommand, cmdObj); if (copyFlag) { TclNewLiteralStringObj(opObj, "copying"); } else { TclNewLiteralStringObj(opObj, "renaming"); } Tcl_ListObjAppendElement(interp, copyCommand, opObj); Tcl_ListObjAppendElement(interp, copyCommand, source); Tcl_ListObjAppendElement(interp, copyCommand, target); Tcl_IncrRefCount(copyCommand); result = Tcl_EvalObjEx(interp, copyCommand, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); Tcl_DecrRefCount(copyCommand); if (result != TCL_OK) { /* * There was an error in the Tcl-level copy. We will pass * on the Tcl error message and can ensure this by setting * errfile to NULL */ errfile = NULL; } } else { errfile = errorBuffer; if (Tcl_FSEqualPaths(errfile, source)) { errfile = source; } else if (Tcl_FSEqualPaths(errfile, target)) { errfile = target; } } } } else { result = Tcl_FSCopyFile(actualSource, target); if ((result != TCL_OK) && (errno == EXDEV)) { result = TclCrossFilesystemCopy(interp, source, target); } if (result != TCL_OK) { /* * We could examine 'errno' to double-check if the problem was * with the target, but we checked the source above, so it should * be quite clear */ errfile = target; } /* * We now need to reset the result, because the above call, * may have left set it. (Ideally we would prefer not to pass * an interpreter in above, but the channel IO code used by * TclCrossFilesystemCopy currently requires one) */ Tcl_ResetResult(interp); } if ((copyFlag == 0) && (result == TCL_OK)) { if (S_ISDIR(sourceStatBuf.st_mode)) { result = Tcl_FSRemoveDirectory(source, 1, &errorBuffer); if (result != TCL_OK) { errfile = errorBuffer; if (Tcl_FSEqualPaths(errfile, source) == 0) { errfile = source; } } } else { result = Tcl_FSDeleteFile(source); if (result != TCL_OK) { errfile = source; } } if (result != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("can't unlink \"%s\": %s", TclGetString(errfile), Tcl_PosixError(interp))); errfile = NULL; } } done: if (errfile != NULL) { Tcl_Obj *errorMsg = Tcl_ObjPrintf("error %s \"%s\"", (copyFlag ? "copying" : "renaming"), TclGetString(source)); if (errfile != source) { Tcl_AppendPrintfToObj(errorMsg, " to \"%s\"", TclGetString(target)); if (errfile != target) { Tcl_AppendPrintfToObj(errorMsg, ": \"%s\"", TclGetString(errfile)); } } Tcl_AppendPrintfToObj(errorMsg, ": %s", Tcl_PosixError(interp)); Tcl_SetObjResult(interp, errorMsg); } if (errorBuffer != NULL) { Tcl_DecrRefCount(errorBuffer); } if (actualSource != NULL) { Tcl_DecrRefCount(actualSource); } return result; }
int TclFileDeleteCmd( ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Used for error reporting */ int objc, /* Number of arguments */ Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */ { int i, force, result; Tcl_Obj *errfile; Tcl_Obj *errorBuffer = NULL; i = FileForceOption(interp, objc - 1, objv + 1, &force); if (i < 0) { return TCL_ERROR; } errfile = NULL; result = TCL_OK; for (i++ ; i < objc; i++) { Tcl_StatBuf statBuf; errfile = objv[i]; if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { result = TCL_ERROR; goto done; } /* * Call lstat() to get info so can delete symbolic link itself. */ if (Tcl_FSLstat(objv[i], &statBuf) != 0) { /* * Trying to delete a file that does not exist is not considered * an error, just a no-op */ if (errno != ENOENT) { result = TCL_ERROR; } } else if (S_ISDIR(statBuf.st_mode)) { /* * We own a reference count on errorBuffer, if it was set as a * result of this call. */ result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer); if (result != TCL_OK) { if ((force == 0) && (errno == EEXIST)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "error deleting \"%s\": directory not empty", TclGetString(objv[i]))); Tcl_PosixError(interp); goto done; } /* * If possible, use the untranslated name for the file. */ errfile = errorBuffer; /* * FS supposed to check between translated objv and errfile. */ if (Tcl_FSEqualPaths(objv[i], errfile)) { errfile = objv[i]; } } } else { result = Tcl_FSDeleteFile(objv[i]); } if (result != TCL_OK) { result = TCL_ERROR; /* * It is important that we break on error, otherwise we might end * up owning reference counts on numerous errorBuffers. */ break; } } if (result != TCL_OK) { if (errfile == NULL) { /* * We try to accomodate poor error results from our Tcl_FS calls. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "error deleting unknown file: %s", Tcl_PosixError(interp))); } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "error deleting \"%s\": %s", TclGetString(errfile), Tcl_PosixError(interp))); } } done: if (errorBuffer != NULL) { Tcl_DecrRefCount(errorBuffer); } return result; }
int TclFileMakeDirsCmd( ClientData clientData, /* Unused */ Tcl_Interp *interp, /* Used for error reporting. */ int objc, /* Number of arguments */ Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */ { Tcl_Obj *errfile = NULL; int result, i, j, pobjc; Tcl_Obj *split = NULL; Tcl_Obj *target = NULL; Tcl_StatBuf statBuf; result = TCL_OK; for (i = 1; i < objc; i++) { if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { result = TCL_ERROR; break; } split = Tcl_FSSplitPath(objv[i], &pobjc); Tcl_IncrRefCount(split); if (pobjc == 0) { errno = ENOENT; errfile = objv[i]; break; } for (j = 0; j < pobjc; j++) { target = Tcl_FSJoinPath(split, j + 1); Tcl_IncrRefCount(target); /* * Call Tcl_FSStat() so that if target is a symlink that points to * a directory we will create subdirectories in that directory. */ if (Tcl_FSStat(target, &statBuf) == 0) { if (!S_ISDIR(statBuf.st_mode)) { errno = EEXIST; errfile = target; goto done; } } else if (errno != ENOENT) { /* * If Tcl_FSStat() failed and the error is anything other than * non-existence of the target, throw the error. */ errfile = target; goto done; } else if (Tcl_FSCreateDirectory(target) != TCL_OK) { /* * Create might have failed because of being in a race * condition with another process trying to create the same * subdirectory. */ if (errno != EEXIST) { errfile = target; goto done; } else if ((Tcl_FSStat(target, &statBuf) == 0) && S_ISDIR(statBuf.st_mode)) { /* * It is a directory that wasn't there before, so keep * going without error. */ Tcl_ResetResult(interp); } else { errfile = target; goto done; } } /* * Forget about this sub-path. */ Tcl_DecrRefCount(target); target = NULL; } Tcl_DecrRefCount(split); split = NULL; } done: if (errfile != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create directory \"%s\": %s", TclGetString(errfile), Tcl_PosixError(interp))); result = TCL_ERROR; } if (split != NULL) { Tcl_DecrRefCount(split); } if (target != NULL) { Tcl_DecrRefCount(target); } return result; }
int TclFileLinkCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Obj *contents; int index; if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "?-linktype? linkname ?target?"); return TCL_ERROR; } /* * Index of the 'source' argument. */ if (objc == 4) { index = 2; } else { index = 1; } if (objc > 2) { int linkAction; if (objc == 4) { /* * We have a '-linktype' argument. */ static const char *const linkTypes[] = { "-symbolic", "-hard", NULL }; if (Tcl_GetIndexFromObj(interp, objv[1], linkTypes, "option", 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 three common error cases specially, and for all other * errors, we use the standard posix error message. */ if (errno == EEXIST) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not create new link \"%s\": that path already" " exists", TclGetString(objv[index]))); Tcl_PosixError(interp); } else if (errno == ENOENT) { /* * There are two cases here: either the target doesn't exist, * or the directory of the src doesn't exist. */ int access; Tcl_Obj *dirPtr = TclPathPart(interp, objv[index], TCL_PATH_DIRNAME); if (dirPtr == NULL) { return TCL_ERROR; } access = Tcl_FSAccess(dirPtr, F_OK); Tcl_DecrRefCount(dirPtr); if (access != 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not create new link \"%s\": no such file" " or directory", TclGetString(objv[index]))); Tcl_PosixError(interp); } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not create new link \"%s\": target \"%s\" " "doesn't exist", TclGetString(objv[index]), TclGetString(objv[index+1]))); errno = ENOENT; Tcl_PosixError(interp); } } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not create new link \"%s\" pointing to \"%s\": %s", TclGetString(objv[index]), TclGetString(objv[index+1]), Tcl_PosixError(interp))); } 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_SetObjResult(interp, Tcl_ObjPrintf( "could not read link \"%s\": %s", TclGetString(objv[index]), Tcl_PosixError(interp))); return TCL_ERROR; } } Tcl_SetObjResult(interp, contents); if (objc == 2) { /* * 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; }
static int FileCopyRename( Tcl_Interp *interp, /* Used for error reporting. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[], /* Argument strings passed to Tcl_FileCmd. */ int copyFlag) /* If non-zero, copy source(s). Otherwise, * rename them. */ { int i, result, force; Tcl_StatBuf statBuf; Tcl_Obj *target; i = FileForceOption(interp, objc - 1, objv + 1, &force); if (i < 0) { return TCL_ERROR; } i++; if ((objc - i) < 2) { Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? source ?source ...? target"); return TCL_ERROR; } /* * If target doesn't exist or isn't a directory, try the copy/rename. More * than 2 arguments is only valid if the target is an existing directory. */ target = objv[objc - 1]; if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) { return TCL_ERROR; } result = TCL_OK; /* * Call Tcl_FSStat() so that if target is a symlink that points to a * directory we will put the sources in that directory instead of * overwriting the symlink. */ if ((Tcl_FSStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { if ((objc - i) > 2) { errno = ENOTDIR; Tcl_PosixError(interp); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "error %s: target \"%s\" is not a directory", (copyFlag?"copying":"renaming"), TclGetString(target))); result = TCL_ERROR; } else { /* * Even though already have target == translated(objv[i+1]), pass * the original argument down, so if there's an error, the error * message will reflect the original arguments. */ result = CopyRenameOneFile(interp, objv[i], objv[i + 1], copyFlag, force); } return result; } /* * Move each source file into target directory. Extract the basename from * each source, and append it to the end of the target path. */ for ( ; i<objc-1 ; i++) { Tcl_Obj *jargv[2]; Tcl_Obj *source, *newFileName; source = FileBasename(interp, objv[i]); if (source == NULL) { result = TCL_ERROR; break; } jargv[0] = objv[objc - 1]; jargv[1] = source; newFileName = TclJoinPath(2, jargv); Tcl_IncrRefCount(newFileName); result = CopyRenameOneFile(interp, objv[i], newFileName, copyFlag, force); Tcl_DecrRefCount(newFileName); Tcl_DecrRefCount(source); if (result == TCL_ERROR) { break; } } return result; }
static void InitVars(Tcl_Interp *interp) { const char *machine, *os, *vers, *user; char *tmp, *p; char buffer[20]; Tcl_DString arch; Tcl_Obj *path; TnmInitPath(interp); Tcl_SetVar2(interp, "tnm", "version", TNM_VERSION, TCL_GLOBAL_ONLY); Tcl_SetVar2(interp, "tnm", "url", TNM_URL, TCL_GLOBAL_ONLY); /* * Get the startup time of the Tnm extension. */ if (! tnmStartTime.sec && ! tnmStartTime.usec) { Tcl_GetTime(&tnmStartTime); } sprintf(buffer, "%ld", tnmStartTime.sec); Tcl_SetVar2(interp, "tnm", "start", buffer, TCL_GLOBAL_ONLY); /* * Check if the current version of the Tnm extension is still valid * or if it has expired. Note, this is only useful in distribution * demos or test versions. This check should be turned off on all * stable and final releases. */ #ifdef TNM_EXPIRE_TIME if (tnmStartTime.sec > TNM_EXPIRE_TIME) { Tcl_Panic("Tnm Tcl extension expired. Please upgrade to a newer version."); } sprintf(buffer, "%ld", TNM_EXPIRE_TIME); Tcl_SetVar2(interp, "tnm", "expire", buffer, TCL_GLOBAL_ONLY); #endif /* * Set the host name. We are only interested in the name and not * in a fully qualified domain name. This makes the result * predictable and thus portable. */ tmp = ckstrdup(Tcl_GetHostName()); p = strchr(tmp, '.'); if (p) *p = '\0'; Tcl_SetVar2(interp, "tnm", "host", tmp, TCL_GLOBAL_ONLY); ckfree(tmp); /* * Get the user name. We try a sequence of different environment * variables in the hope to find something which works on all * systems. */ user = getenv("USER"); if (user == NULL) { user = getenv("USERNAME"); if (user == NULL) { user = getenv("LOGNAME"); if (user == NULL) { user = "******"; } } } Tcl_SetVar2(interp, "tnm", "user", user, TCL_GLOBAL_ONLY); /* * Search for a directory which allows to hold temporary files. * Save the directory name in the tnm(tmp) variable. */ tmp = getenv("TEMP"); if (! tmp) { tmp = getenv("TMP"); if (! tmp) { tmp = "/tmp"; if (access(tmp, W_OK) != 0) { tmp = "."; } } } for (p = tmp; *p; p++) { if (*p == '\\') { *p = '/'; } } Tcl_SetVar2(interp, "tnm", "tmp", tmp, TCL_GLOBAL_ONLY); /* * Determine the architecture string which is used to store * machine dependend files in the Tnm cache area. */ machine = Tcl_GetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY); os = Tcl_GetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY); vers = Tcl_GetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY); Tcl_DStringInit(&arch); if (machine && os && vers) { Tcl_DStringAppend(&arch, machine, -1); Tcl_DStringAppend(&arch, "-", 1); Tcl_DStringAppend(&arch, os, -1); Tcl_DStringAppend(&arch, "-", 1); Tcl_DStringAppend(&arch, vers, -1); } else { Tcl_DStringAppend(&arch, "unknown-os", -1); } /* * Initialize the tnm(cache) variable which points to a directory * where we can cache shared data between different instantiations * of the Tnm extension. We usually locate the cache in the users * home directory. However, if this fails (because the user does * not have a home), we locate the cache in the tmp file area. */ path = Tcl_NewObj(); Tcl_AppendStringsToObj(path, "~/.tnm", TNM_VERSION, NULL); if (Tcl_FSConvertToPathType(interp, path) == TCL_ERROR) { Tcl_SetStringObj(path, tmp, -1); Tcl_AppendStringsToObj(path, "/tnm", TNM_VERSION, NULL); } if (Tcl_FSConvertToPathType(interp, path) == TCL_OK) { (void) TnmMkDir(interp, path); } Tcl_SetVar2(interp, "tnm", "cache", Tcl_GetStringFromObj(path, NULL), TCL_GLOBAL_ONLY); Tcl_DecrRefCount(path); /* * Remove all white spaces and slashes from the architecture string * because these characters are a potential source of problems and * I really do not like white spaces in a directory name. */ { char *d = Tcl_DStringValue(&arch); char *s = Tcl_DStringValue(&arch); while (*s) { *d = *s; if ((!isspace((int) *s)) && (*s != '/')) d++; s++; } *d = '\0'; } Tcl_SetVar2(interp, "tnm", "arch", Tcl_DStringValue(&arch), TCL_GLOBAL_ONLY); Tcl_DStringFree(&arch); }