sl@0: /* sl@0: * tclFCmd.c sl@0: * sl@0: * This file implements the generic portion of file manipulation sl@0: * subcommands of the "file" command. sl@0: * sl@0: * Copyright (c) 1996-1998 Sun Microsystems, Inc. sl@0: * sl@0: * See the file "license.terms" for information on usage and redistribution sl@0: * of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: * sl@0: * RCS: @(#) $Id: tclFCmd.c,v 1.20.2.2 2005/08/17 17:46:36 hobbs Exp $ sl@0: */ sl@0: sl@0: #include "tclInt.h" sl@0: #include "tclPort.h" sl@0: sl@0: /* sl@0: * Declarations for local procedures defined in this file: sl@0: */ sl@0: sl@0: static int CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr, sl@0: int copyFlag, int force)); sl@0: static Tcl_Obj * FileBasename _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Obj *pathPtr)); sl@0: static int FileCopyRename _ANSI_ARGS_((Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[], int copyFlag)); sl@0: static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp, sl@0: int objc, Tcl_Obj *CONST objv[], int *forcePtr)); sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * TclFileRenameCmd sl@0: * sl@0: * This procedure implements the "rename" subcommand of the "file" sl@0: * command. Filename arguments need to be translated to native sl@0: * format before being passed to platform-specific code that sl@0: * implements rename functionality. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclFileRenameCmd(interp, objc, objv) sl@0: Tcl_Interp *interp; /* Interp for error reporting. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ sl@0: { sl@0: return FileCopyRename(interp, objc, objv, 0); sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * TclFileCopyCmd sl@0: * sl@0: * This procedure implements the "copy" subcommand of the "file" sl@0: * command. Filename arguments need to be translated to native sl@0: * format before being passed to platform-specific code that sl@0: * implements copy functionality. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclFileCopyCmd(interp, objc, objv) sl@0: Tcl_Interp *interp; /* Used for error reporting */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ sl@0: { sl@0: return FileCopyRename(interp, objc, objv, 1); sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * FileCopyRename -- sl@0: * sl@0: * Performs the work of TclFileRenameCmd and TclFileCopyCmd. sl@0: * See comments for those procedures. sl@0: * sl@0: * Results: sl@0: * See above. sl@0: * sl@0: * Side effects: sl@0: * See above. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: FileCopyRename(interp, objc, objv, copyFlag) sl@0: Tcl_Interp *interp; /* Used for error reporting. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ sl@0: int copyFlag; /* If non-zero, copy source(s). Otherwise, sl@0: * rename them. */ sl@0: { sl@0: int i, result, force; sl@0: Tcl_StatBuf statBuf; sl@0: Tcl_Obj *target; sl@0: sl@0: i = FileForceOption(interp, objc - 2, objv + 2, &force); sl@0: if (i < 0) { sl@0: return TCL_ERROR; sl@0: } sl@0: i += 2; sl@0: if ((objc - i) < 2) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", sl@0: Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]), sl@0: " ?options? source ?source ...? target\"", sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: /* sl@0: * If target doesn't exist or isn't a directory, try the copy/rename. sl@0: * More than 2 arguments is only valid if the target is an existing sl@0: * directory. sl@0: */ sl@0: sl@0: target = objv[objc - 1]; sl@0: if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: result = TCL_OK; sl@0: sl@0: /* sl@0: * Call Tcl_FSStat() so that if target is a symlink that points to a sl@0: * directory we will put the sources in that directory instead of sl@0: * overwriting the symlink. sl@0: */ sl@0: sl@0: if ((Tcl_FSStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) { sl@0: if ((objc - i) > 2) { sl@0: errno = ENOTDIR; sl@0: Tcl_PosixError(interp); sl@0: Tcl_AppendResult(interp, "error ", sl@0: ((copyFlag) ? "copying" : "renaming"), ": target \"", sl@0: Tcl_GetString(target), "\" is not a directory", sl@0: (char *) NULL); sl@0: result = TCL_ERROR; sl@0: } else { sl@0: /* sl@0: * Even though already have target == translated(objv[i+1]), sl@0: * pass the original argument down, so if there's an error, the sl@0: * error message will reflect the original arguments. sl@0: */ sl@0: sl@0: result = CopyRenameOneFile(interp, objv[i], objv[i + 1], copyFlag, sl@0: force); sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: * Move each source file into target directory. Extract the basename sl@0: * from each source, and append it to the end of the target path. sl@0: */ sl@0: sl@0: for ( ; i < objc - 1; i++) { sl@0: Tcl_Obj *jargv[2]; sl@0: Tcl_Obj *source, *newFileName; sl@0: Tcl_Obj *temp; sl@0: sl@0: source = FileBasename(interp, objv[i]); sl@0: if (source == NULL) { sl@0: result = TCL_ERROR; sl@0: break; sl@0: } sl@0: jargv[0] = objv[objc - 1]; sl@0: jargv[1] = source; sl@0: temp = Tcl_NewListObj(2, jargv); sl@0: newFileName = Tcl_FSJoinPath(temp, -1); sl@0: Tcl_IncrRefCount(newFileName); sl@0: result = CopyRenameOneFile(interp, objv[i], newFileName, copyFlag, sl@0: force); sl@0: Tcl_DecrRefCount(newFileName); sl@0: Tcl_DecrRefCount(temp); sl@0: Tcl_DecrRefCount(source); sl@0: sl@0: if (result == TCL_ERROR) { sl@0: break; sl@0: } sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * TclFileMakeDirsCmd sl@0: * sl@0: * This procedure implements the "mkdir" subcommand of the "file" sl@0: * command. Filename arguments need to be translated to native sl@0: * format before being passed to platform-specific code that sl@0: * implements mkdir functionality. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: int sl@0: TclFileMakeDirsCmd(interp, objc, objv) sl@0: Tcl_Interp *interp; /* Used for error reporting. */ sl@0: int objc; /* Number of arguments */ sl@0: Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ sl@0: { sl@0: Tcl_Obj *errfile; sl@0: int result, i, j, pobjc; sl@0: Tcl_Obj *split = NULL; sl@0: Tcl_Obj *target = NULL; sl@0: Tcl_StatBuf statBuf; sl@0: sl@0: errfile = NULL; sl@0: sl@0: result = TCL_OK; sl@0: for (i = 2; i < objc; i++) { sl@0: if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { sl@0: result = TCL_ERROR; sl@0: break; sl@0: } sl@0: sl@0: split = Tcl_FSSplitPath(objv[i],&pobjc); sl@0: if (pobjc == 0) { sl@0: errno = ENOENT; sl@0: errfile = objv[i]; sl@0: break; sl@0: } sl@0: for (j = 0; j < pobjc; j++) { sl@0: target = Tcl_FSJoinPath(split, j + 1); sl@0: Tcl_IncrRefCount(target); sl@0: /* sl@0: * Call Tcl_FSStat() so that if target is a symlink that sl@0: * points to a directory we will create subdirectories in sl@0: * that directory. sl@0: */ sl@0: sl@0: if (Tcl_FSStat(target, &statBuf) == 0) { sl@0: if (!S_ISDIR(statBuf.st_mode)) { sl@0: errno = EEXIST; sl@0: errfile = target; sl@0: goto done; sl@0: } sl@0: } else if (errno != ENOENT) { sl@0: /* sl@0: * If Tcl_FSStat() failed and the error is anything sl@0: * other than non-existence of the target, throw the sl@0: * error. sl@0: */ sl@0: errfile = target; sl@0: goto done; sl@0: } else if (Tcl_FSCreateDirectory(target) != TCL_OK) { sl@0: /* sl@0: * Create might have failed because of being in a race sl@0: * condition with another process trying to create the sl@0: * same subdirectory. sl@0: */ sl@0: if (errno == EEXIST) { sl@0: if ((Tcl_FSStat(target, &statBuf) == 0) sl@0: && S_ISDIR(statBuf.st_mode)) { sl@0: /* sl@0: * It is a directory that wasn't there before, sl@0: * so keep going without error. sl@0: */ sl@0: Tcl_ResetResult(interp); sl@0: } else { sl@0: errfile = target; sl@0: goto done; sl@0: } sl@0: } else { sl@0: errfile = target; sl@0: goto done; sl@0: } sl@0: } sl@0: /* Forget about this sub-path */ sl@0: Tcl_DecrRefCount(target); sl@0: target = NULL; sl@0: } sl@0: Tcl_DecrRefCount(split); sl@0: split = NULL; sl@0: } sl@0: sl@0: done: sl@0: if (errfile != NULL) { sl@0: Tcl_AppendResult(interp, "can't create directory \"", sl@0: Tcl_GetString(errfile), "\": ", Tcl_PosixError(interp), sl@0: (char *) NULL); sl@0: result = TCL_ERROR; sl@0: } sl@0: if (split != NULL) { sl@0: Tcl_DecrRefCount(split); sl@0: } sl@0: if (target != NULL) { sl@0: Tcl_DecrRefCount(target); sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclFileDeleteCmd sl@0: * sl@0: * This procedure implements the "delete" subcommand of the "file" sl@0: * command. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * See the user documentation. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclFileDeleteCmd(interp, objc, objv) sl@0: Tcl_Interp *interp; /* Used for error reporting */ sl@0: int objc; /* Number of arguments */ sl@0: Tcl_Obj *CONST objv[]; /* Argument strings passed to Tcl_FileCmd. */ sl@0: { sl@0: int i, force, result; sl@0: Tcl_Obj *errfile; sl@0: Tcl_Obj *errorBuffer = NULL; sl@0: sl@0: i = FileForceOption(interp, objc - 2, objv + 2, &force); sl@0: if (i < 0) { sl@0: return TCL_ERROR; sl@0: } sl@0: i += 2; sl@0: if ((objc - i) < 1) { sl@0: Tcl_AppendResult(interp, "wrong # args: should be \"", sl@0: Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]), sl@0: " ?options? file ?file ...?\"", (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: errfile = NULL; sl@0: result = TCL_OK; sl@0: sl@0: for ( ; i < objc; i++) { sl@0: Tcl_StatBuf statBuf; sl@0: sl@0: errfile = objv[i]; sl@0: if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) { sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: sl@0: /* sl@0: * Call lstat() to get info so can delete symbolic link itself. sl@0: */ sl@0: sl@0: if (Tcl_FSLstat(objv[i], &statBuf) != 0) { sl@0: /* sl@0: * Trying to delete a file that does not exist is not sl@0: * considered an error, just a no-op sl@0: */ sl@0: sl@0: if (errno != ENOENT) { sl@0: result = TCL_ERROR; sl@0: } sl@0: } else if (S_ISDIR(statBuf.st_mode)) { sl@0: /* sl@0: * We own a reference count on errorBuffer, if it was set sl@0: * as a result of this call. sl@0: */ sl@0: result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer); sl@0: if (result != TCL_OK) { sl@0: if ((force == 0) && (errno == EEXIST)) { sl@0: Tcl_AppendResult(interp, "error deleting \"", sl@0: Tcl_GetString(objv[i]), sl@0: "\": directory not empty", (char *) NULL); sl@0: Tcl_PosixError(interp); sl@0: goto done; sl@0: } sl@0: sl@0: /* sl@0: * If possible, use the untranslated name for the file. sl@0: */ sl@0: sl@0: errfile = errorBuffer; sl@0: /* FS supposed to check between translated objv and errfile */ sl@0: if (Tcl_FSEqualPaths(objv[i], errfile)) { sl@0: errfile = objv[i]; sl@0: } sl@0: } sl@0: } else { sl@0: result = Tcl_FSDeleteFile(objv[i]); sl@0: } sl@0: sl@0: if (result != TCL_OK) { sl@0: result = TCL_ERROR; sl@0: /* sl@0: * It is important that we break on error, otherwise we sl@0: * might end up owning reference counts on numerous sl@0: * errorBuffers. sl@0: */ sl@0: break; sl@0: } sl@0: } sl@0: if (result != TCL_OK) { sl@0: if (errfile == NULL) { sl@0: /* sl@0: * We try to accomodate poor error results from our sl@0: * Tcl_FS calls sl@0: */ sl@0: Tcl_AppendResult(interp, "error deleting unknown file: ", sl@0: Tcl_PosixError(interp), (char *) NULL); sl@0: } else { sl@0: Tcl_AppendResult(interp, "error deleting \"", sl@0: Tcl_GetString(errfile), "\": ", sl@0: Tcl_PosixError(interp), (char *) NULL); sl@0: } sl@0: } sl@0: done: sl@0: if (errorBuffer != NULL) { sl@0: Tcl_DecrRefCount(errorBuffer); sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * CopyRenameOneFile sl@0: * sl@0: * Copies or renames specified source file or directory hierarchy sl@0: * to the specified target. sl@0: * sl@0: * Results: sl@0: * A standard Tcl result. sl@0: * sl@0: * Side effects: sl@0: * Target is overwritten if the force flag is set. Attempting to sl@0: * copy/rename a file onto a directory or a directory onto a file sl@0: * will always result in an error. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: CopyRenameOneFile(interp, source, target, copyFlag, force) sl@0: Tcl_Interp *interp; /* Used for error reporting. */ sl@0: Tcl_Obj *source; /* Pathname of file to copy. May need to sl@0: * be translated. */ sl@0: Tcl_Obj *target; /* Pathname of file to create/overwrite. sl@0: * May need to be translated. */ sl@0: int copyFlag; /* If non-zero, copy files. Otherwise, sl@0: * rename them. */ sl@0: int force; /* If non-zero, overwrite target file if it sl@0: * exists. Otherwise, error if target already sl@0: * exists. */ sl@0: { sl@0: int result; sl@0: Tcl_Obj *errfile, *errorBuffer; sl@0: /* If source is a link, then this is the real file/directory */ sl@0: Tcl_Obj *actualSource = NULL; sl@0: Tcl_StatBuf sourceStatBuf, targetStatBuf; sl@0: sl@0: if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: errfile = NULL; sl@0: errorBuffer = NULL; sl@0: result = TCL_ERROR; sl@0: sl@0: /* sl@0: * We want to copy/rename links and not the files they point to, so we sl@0: * use lstat(). If target is a link, we also want to replace the sl@0: * link and not the file it points to, so we also use lstat() on the sl@0: * target. sl@0: */ sl@0: sl@0: if (Tcl_FSLstat(source, &sourceStatBuf) != 0) { sl@0: errfile = source; sl@0: goto done; sl@0: } sl@0: if (Tcl_FSLstat(target, &targetStatBuf) != 0) { sl@0: if (errno != ENOENT) { sl@0: errfile = target; sl@0: goto done; sl@0: } sl@0: } else { sl@0: if (force == 0) { sl@0: errno = EEXIST; sl@0: errfile = target; sl@0: goto done; sl@0: } sl@0: sl@0: /* sl@0: * Prevent copying or renaming a file onto itself. Under Windows, sl@0: * stat always returns 0 for st_ino. However, the Windows-specific sl@0: * code knows how to deal with copying or renaming a file on top of sl@0: * itself. It might be a good idea to write a stat that worked. sl@0: */ sl@0: sl@0: if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) { sl@0: if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) && sl@0: (sourceStatBuf.st_dev == targetStatBuf.st_dev)) { sl@0: result = TCL_OK; sl@0: goto done; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Prevent copying/renaming a file onto a directory and sl@0: * vice-versa. This is a policy decision based on the fact that sl@0: * existing implementations of copy and rename on all platforms sl@0: * also prevent this. sl@0: */ sl@0: sl@0: if (S_ISDIR(sourceStatBuf.st_mode) sl@0: && !S_ISDIR(targetStatBuf.st_mode)) { sl@0: errno = EISDIR; sl@0: Tcl_AppendResult(interp, "can't overwrite file \"", sl@0: Tcl_GetString(target), "\" with directory \"", sl@0: Tcl_GetString(source), "\"", (char *) NULL); sl@0: goto done; sl@0: } sl@0: if (!S_ISDIR(sourceStatBuf.st_mode) sl@0: && S_ISDIR(targetStatBuf.st_mode)) { sl@0: errno = EISDIR; sl@0: Tcl_AppendResult(interp, "can't overwrite directory \"", sl@0: Tcl_GetString(target), "\" with file \"", sl@0: Tcl_GetString(source), "\"", (char *) NULL); sl@0: goto done; sl@0: } sl@0: } sl@0: sl@0: if (copyFlag == 0) { sl@0: result = Tcl_FSRenameFile(source, target); sl@0: if (result == TCL_OK) { sl@0: goto done; sl@0: } sl@0: sl@0: if (errno == EINVAL) { sl@0: Tcl_AppendResult(interp, "error renaming \"", sl@0: Tcl_GetString(source), "\" to \"", sl@0: Tcl_GetString(target), "\": trying to rename a volume or ", sl@0: "move a directory into itself", (char *) NULL); sl@0: goto done; sl@0: } else if (errno != EXDEV) { sl@0: errfile = target; sl@0: goto done; sl@0: } sl@0: sl@0: /* sl@0: * The rename failed because the move was across file systems. sl@0: * Fall through to copy file and then remove original. Note that sl@0: * the low-level Tcl_FSRenameFileProc in the filesystem is allowed sl@0: * to implement cross-filesystem moves itself, if it desires. sl@0: */ sl@0: } sl@0: sl@0: actualSource = source; sl@0: Tcl_IncrRefCount(actualSource); sl@0: #if 0 sl@0: #ifdef S_ISLNK sl@0: /* sl@0: * To add a flag to make 'copy' copy links instead of files, we could sl@0: * add a condition to ignore this 'if' here. sl@0: */ sl@0: if (copyFlag && S_ISLNK(sourceStatBuf.st_mode)) { sl@0: /* sl@0: * We want to copy files not links. Therefore we must follow the sl@0: * link. There are two purposes to this 'stat' call here. First sl@0: * we want to know if the linked-file/dir actually exists, and sl@0: * second, in the block of code which follows, some 20 lines sl@0: * down, we want to check if the thing is a file or directory. sl@0: */ sl@0: if (Tcl_FSStat(source, &sourceStatBuf) != 0) { sl@0: /* Actual file doesn't exist */ sl@0: Tcl_AppendResult(interp, sl@0: "error copying \"", Tcl_GetString(source), sl@0: "\": the target of this link doesn't exist", sl@0: (char *) NULL); sl@0: goto done; sl@0: } else { sl@0: int counter = 0; sl@0: while (1) { sl@0: Tcl_Obj *path = Tcl_FSLink(actualSource, NULL, 0); sl@0: if (path == NULL) { sl@0: break; sl@0: } sl@0: Tcl_DecrRefCount(actualSource); sl@0: actualSource = path; sl@0: counter++; sl@0: /* Arbitrary limit of 20 links to follow */ sl@0: if (counter > 20) { sl@0: /* Too many links */ sl@0: Tcl_SetErrno(EMLINK); sl@0: errfile = source; sl@0: goto done; sl@0: } sl@0: } sl@0: /* Now 'actualSource' is the correct file */ sl@0: } sl@0: } sl@0: #endif sl@0: #endif sl@0: sl@0: if (S_ISDIR(sourceStatBuf.st_mode)) { sl@0: result = Tcl_FSCopyDirectory(actualSource, target, &errorBuffer); sl@0: if (result != TCL_OK) { sl@0: if (errno == EXDEV) { sl@0: /* sl@0: * The copy failed because we're trying to do a sl@0: * cross-filesystem copy. We do this through our Tcl sl@0: * library. sl@0: */ sl@0: Tcl_SavedResult savedResult; sl@0: Tcl_Obj *copyCommand = Tcl_NewListObj(0,NULL); sl@0: Tcl_IncrRefCount(copyCommand); sl@0: Tcl_ListObjAppendElement(interp, copyCommand, sl@0: Tcl_NewStringObj("::tcl::CopyDirectory",-1)); sl@0: if (copyFlag) { sl@0: Tcl_ListObjAppendElement(interp, copyCommand, sl@0: Tcl_NewStringObj("copying",-1)); sl@0: } else { sl@0: Tcl_ListObjAppendElement(interp, copyCommand, sl@0: Tcl_NewStringObj("renaming",-1)); sl@0: } sl@0: Tcl_ListObjAppendElement(interp, copyCommand, source); sl@0: Tcl_ListObjAppendElement(interp, copyCommand, target); sl@0: Tcl_SaveResult(interp, &savedResult); sl@0: result = Tcl_EvalObjEx(interp, copyCommand, sl@0: TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); sl@0: Tcl_DecrRefCount(copyCommand); sl@0: if (result != TCL_OK) { sl@0: /* sl@0: * There was an error in the Tcl-level copy. sl@0: * We will pass on the Tcl error message and sl@0: * can ensure this by setting errfile to NULL sl@0: */ sl@0: Tcl_DiscardResult(&savedResult); sl@0: errfile = NULL; sl@0: } else { sl@0: /* The copy was successful */ sl@0: Tcl_RestoreResult(interp, &savedResult); sl@0: } sl@0: } else { sl@0: errfile = errorBuffer; sl@0: if (Tcl_FSEqualPaths(errfile, source)) { sl@0: errfile = source; sl@0: } else if (Tcl_FSEqualPaths(errfile, target)) { sl@0: errfile = target; sl@0: } sl@0: } sl@0: } sl@0: } else { sl@0: result = Tcl_FSCopyFile(actualSource, target); sl@0: if ((result != TCL_OK) && (errno == EXDEV)) { sl@0: result = TclCrossFilesystemCopy(interp, source, target); sl@0: } sl@0: if (result != TCL_OK) { sl@0: /* sl@0: * We could examine 'errno' to double-check if the problem sl@0: * was with the target, but we checked the source above, sl@0: * so it should be quite clear sl@0: */ sl@0: errfile = target; sl@0: /* sl@0: * We now need to reset the result, because the above call, sl@0: * if it failed, may have put an error message in place. sl@0: * (Ideally we would prefer not to pass an interpreter in sl@0: * above, but the channel IO code used by sl@0: * TclCrossFilesystemCopy currently requires one) sl@0: */ sl@0: Tcl_ResetResult(interp); sl@0: } sl@0: } sl@0: if ((copyFlag == 0) && (result == TCL_OK)) { sl@0: if (S_ISDIR(sourceStatBuf.st_mode)) { sl@0: result = Tcl_FSRemoveDirectory(source, 1, &errorBuffer); sl@0: if (result != TCL_OK) { sl@0: if (Tcl_FSEqualPaths(errfile, source) == 0) { sl@0: errfile = source; sl@0: } sl@0: } sl@0: } else { sl@0: result = Tcl_FSDeleteFile(source); sl@0: if (result != TCL_OK) { sl@0: errfile = source; sl@0: } sl@0: } sl@0: if (result != TCL_OK) { sl@0: Tcl_AppendResult(interp, "can't unlink \"", sl@0: Tcl_GetString(errfile), "\": ", sl@0: Tcl_PosixError(interp), (char *) NULL); sl@0: errfile = NULL; sl@0: } sl@0: } sl@0: sl@0: done: sl@0: if (errfile != NULL) { sl@0: Tcl_AppendResult(interp, sl@0: ((copyFlag) ? "error copying \"" : "error renaming \""), sl@0: Tcl_GetString(source), (char *) NULL); sl@0: if (errfile != source) { sl@0: Tcl_AppendResult(interp, "\" to \"", Tcl_GetString(target), sl@0: (char *) NULL); sl@0: if (errfile != target) { sl@0: Tcl_AppendResult(interp, "\": \"", Tcl_GetString(errfile), sl@0: (char *) NULL); sl@0: } sl@0: } sl@0: Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), sl@0: (char *) NULL); sl@0: } sl@0: if (errorBuffer != NULL) { sl@0: Tcl_DecrRefCount(errorBuffer); sl@0: } sl@0: if (actualSource != NULL) { sl@0: Tcl_DecrRefCount(actualSource); sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * FileForceOption -- sl@0: * sl@0: * Helps parse command line options for file commands that take sl@0: * the "-force" and "--" options. sl@0: * sl@0: * Results: sl@0: * The return value is how many arguments from argv were consumed sl@0: * by this function, or -1 if there was an error parsing the sl@0: * options. If an error occurred, an error message is left in the sl@0: * interp's result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: FileForceOption(interp, objc, objv, forcePtr) sl@0: Tcl_Interp *interp; /* Interp, for error return. */ sl@0: int objc; /* Number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* Argument strings. First command line sl@0: * option, if it exists, begins at 0. */ sl@0: int *forcePtr; /* If the "-force" was specified, *forcePtr sl@0: * is filled with 1, otherwise with 0. */ sl@0: { sl@0: int force, i; sl@0: sl@0: force = 0; sl@0: for (i = 0; i < objc; i++) { sl@0: if (Tcl_GetString(objv[i])[0] != '-') { sl@0: break; sl@0: } sl@0: if (strcmp(Tcl_GetString(objv[i]), "-force") == 0) { sl@0: force = 1; sl@0: } else if (strcmp(Tcl_GetString(objv[i]), "--") == 0) { sl@0: i++; sl@0: break; sl@0: } else { sl@0: Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[i]), sl@0: "\": should be -force or --", (char *)NULL); sl@0: return -1; sl@0: } sl@0: } sl@0: *forcePtr = force; sl@0: return i; sl@0: } sl@0: /* sl@0: *--------------------------------------------------------------------------- sl@0: * sl@0: * FileBasename -- sl@0: * sl@0: * Given a path in either tcl format (with / separators), or in the sl@0: * platform-specific format for the current platform, return all the sl@0: * characters in the path after the last directory separator. But, sl@0: * if path is the root directory, returns no characters. sl@0: * sl@0: * Results: sl@0: * Returns the string object that represents the basename. If there sl@0: * is an error, an error message is left in interp, and NULL is sl@0: * returned. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *--------------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static Tcl_Obj * sl@0: FileBasename(interp, pathPtr) sl@0: Tcl_Interp *interp; /* Interp, for error return. */ sl@0: Tcl_Obj *pathPtr; /* Path whose basename to extract. */ sl@0: { sl@0: int objc; sl@0: Tcl_Obj *splitPtr; sl@0: Tcl_Obj *resultPtr = NULL; sl@0: sl@0: splitPtr = Tcl_FSSplitPath(pathPtr, &objc); sl@0: sl@0: if (objc != 0) { sl@0: if ((objc == 1) && (*Tcl_GetString(pathPtr) == '~')) { sl@0: Tcl_DecrRefCount(splitPtr); sl@0: if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { sl@0: return NULL; sl@0: } sl@0: splitPtr = Tcl_FSSplitPath(pathPtr, &objc); sl@0: } sl@0: sl@0: /* sl@0: * Return the last component, unless it is the only component, and it sl@0: * is the root of an absolute path. sl@0: */ sl@0: sl@0: if (objc > 0) { sl@0: Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr); sl@0: if ((objc == 1) && sl@0: (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) { sl@0: resultPtr = NULL; sl@0: } sl@0: } sl@0: } sl@0: if (resultPtr == NULL) { sl@0: resultPtr = Tcl_NewObj(); sl@0: } sl@0: Tcl_IncrRefCount(resultPtr); sl@0: Tcl_DecrRefCount(splitPtr); sl@0: return resultPtr; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclFileAttrsCmd -- sl@0: * sl@0: * Sets or gets the platform-specific attributes of a file. The sl@0: * objc-objv points to the file name with the rest of the command sl@0: * line following. This routine uses platform-specific tables of sl@0: * option strings and callbacks. The callback to get the sl@0: * attributes take three parameters: sl@0: * Tcl_Interp *interp; The interp to report errors with. sl@0: * Since this is an object-based API, sl@0: * the object form of the result should sl@0: * be used. sl@0: * CONST char *fileName; This is extracted using sl@0: * Tcl_TranslateFileName. sl@0: * TclObj **attrObjPtrPtr; A new object to hold the attribute sl@0: * is allocated and put here. sl@0: * The first two parameters of the callback used to write out the sl@0: * attributes are the same. The third parameter is: sl@0: * CONST *attrObjPtr; A pointer to the object that has sl@0: * the new attribute. sl@0: * They both return standard TCL errors; if the routine to get sl@0: * an attribute fails, no object is allocated and *attrObjPtrPtr sl@0: * is unchanged. sl@0: * sl@0: * Results: sl@0: * Standard TCL error. sl@0: * sl@0: * Side effects: sl@0: * May set file attributes for the file name. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclFileAttrsCmd(interp, objc, objv) sl@0: Tcl_Interp *interp; /* The interpreter for error reporting. */ sl@0: int objc; /* Number of command line arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* The command line objects. */ sl@0: { sl@0: int result; sl@0: CONST char ** attributeStrings; sl@0: Tcl_Obj* objStrings = NULL; sl@0: int numObjStrings = -1; sl@0: Tcl_Obj *filePtr; sl@0: sl@0: if (objc < 3) { sl@0: Tcl_WrongNumArgs(interp, 2, objv, sl@0: "name ?option? ?value? ?option value ...?"); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: filePtr = objv[2]; sl@0: if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) { sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: objc -= 3; sl@0: objv += 3; sl@0: result = TCL_ERROR; sl@0: Tcl_SetErrno(0); sl@0: attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings); sl@0: if (attributeStrings == NULL) { sl@0: int index; sl@0: Tcl_Obj *objPtr; sl@0: if (objStrings == NULL) { sl@0: if (Tcl_GetErrno() != 0) { sl@0: /* sl@0: * There was an error, probably that the filePtr is sl@0: * not accepted by any filesystem sl@0: */ sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "could not read \"", Tcl_GetString(filePtr), sl@0: "\": ", Tcl_PosixError(interp), sl@0: (char *) NULL); sl@0: return TCL_ERROR; sl@0: } sl@0: goto end; sl@0: } sl@0: /* We own the object now */ sl@0: Tcl_IncrRefCount(objStrings); sl@0: /* Use objStrings as a list object */ sl@0: if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) { sl@0: goto end; sl@0: } sl@0: attributeStrings = (CONST char **) sl@0: ckalloc ((1+numObjStrings) * sizeof(char*)); sl@0: for (index = 0; index < numObjStrings; index++) { sl@0: Tcl_ListObjIndex(interp, objStrings, index, &objPtr); sl@0: attributeStrings[index] = Tcl_GetString(objPtr); sl@0: } sl@0: attributeStrings[index] = NULL; sl@0: } sl@0: if (objc == 0) { sl@0: /* sl@0: * Get all attributes. sl@0: */ sl@0: sl@0: int index; sl@0: Tcl_Obj *listPtr; sl@0: sl@0: listPtr = Tcl_NewListObj(0, NULL); sl@0: for (index = 0; attributeStrings[index] != NULL; index++) { sl@0: Tcl_Obj *objPtr = Tcl_NewStringObj(attributeStrings[index], -1); sl@0: Tcl_ListObjAppendElement(interp, listPtr, objPtr); sl@0: /* We now forget about objPtr, it is in the list */ sl@0: objPtr = NULL; sl@0: if (Tcl_FSFileAttrsGet(interp, index, filePtr, sl@0: &objPtr) != TCL_OK) { sl@0: Tcl_DecrRefCount(listPtr); sl@0: goto end; sl@0: } sl@0: Tcl_ListObjAppendElement(interp, listPtr, objPtr); sl@0: } sl@0: Tcl_SetObjResult(interp, listPtr); sl@0: } else if (objc == 1) { sl@0: /* sl@0: * Get one attribute. sl@0: */ sl@0: sl@0: int index; sl@0: Tcl_Obj *objPtr = NULL; sl@0: sl@0: if (numObjStrings == 0) { sl@0: Tcl_AppendResult(interp, "bad option \"", sl@0: Tcl_GetString(objv[0]), "\", there are no file attributes" sl@0: " in this filesystem.", (char *) NULL); sl@0: goto end; sl@0: } sl@0: sl@0: if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings, sl@0: "option", 0, &index) != TCL_OK) { sl@0: goto end; sl@0: } sl@0: if (Tcl_FSFileAttrsGet(interp, index, filePtr, sl@0: &objPtr) != TCL_OK) { sl@0: goto end; sl@0: } sl@0: Tcl_SetObjResult(interp, objPtr); sl@0: } else { sl@0: /* sl@0: * Set option/value pairs. sl@0: */ sl@0: sl@0: int i, index; sl@0: sl@0: if (numObjStrings == 0) { sl@0: Tcl_AppendResult(interp, "bad option \"", sl@0: Tcl_GetString(objv[0]), "\", there are no file attributes" sl@0: " in this filesystem.", (char *) NULL); sl@0: goto end; sl@0: } sl@0: sl@0: for (i = 0; i < objc ; i += 2) { sl@0: if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings, sl@0: "option", 0, &index) != TCL_OK) { sl@0: goto end; sl@0: } sl@0: if (i + 1 == objc) { sl@0: Tcl_AppendResult(interp, "value for \"", sl@0: Tcl_GetString(objv[i]), "\" missing", sl@0: (char *) NULL); sl@0: goto end; sl@0: } sl@0: if (Tcl_FSFileAttrsSet(interp, index, filePtr, sl@0: objv[i + 1]) != TCL_OK) { sl@0: goto end; sl@0: } sl@0: } sl@0: } sl@0: result = TCL_OK; sl@0: sl@0: end: sl@0: if (numObjStrings != -1) { sl@0: /* Free up the array we allocated */ sl@0: ckfree((char*)attributeStrings); sl@0: /* sl@0: * We don't need this object that was passed to us sl@0: * any more. sl@0: */ sl@0: if (objStrings != NULL) { sl@0: Tcl_DecrRefCount(objStrings); sl@0: } sl@0: } sl@0: return result; sl@0: }