summaryrefslogtreecommitdiffstats
path: root/tcl8.6/generic/tclFCmd.c
diff options
context:
space:
mode:
authorWilliam Joye <wjoye@cfa.harvard.edu>2017-10-17 19:50:58 (GMT)
committerWilliam Joye <wjoye@cfa.harvard.edu>2017-10-17 19:50:58 (GMT)
commit9b7a6c3507ea3383c60aaecb29f873c9b590ccca (patch)
tree82ce31ebd8f46803d969034f5aa3db8d7974493c /tcl8.6/generic/tclFCmd.c
parent87fca7325b97005eb44dcf3e198277640af66115 (diff)
downloadblt-9b7a6c3507ea3383c60aaecb29f873c9b590ccca.zip
blt-9b7a6c3507ea3383c60aaecb29f873c9b590ccca.tar.gz
blt-9b7a6c3507ea3383c60aaecb29f873c9b590ccca.tar.bz2
rm tcl/tk 8.6.7
Diffstat (limited to 'tcl8.6/generic/tclFCmd.c')
-rw-r--r--tcl8.6/generic/tclFCmd.c1513
1 files changed, 0 insertions, 1513 deletions
diff --git a/tcl8.6/generic/tclFCmd.c b/tcl8.6/generic/tclFCmd.c
deleted file mode 100644
index bb814ea..0000000
--- a/tcl8.6/generic/tclFCmd.c
+++ /dev/null
@@ -1,1513 +0,0 @@
-/*
- * tclFCmd.c
- *
- * This file implements the generic portion of file manipulation
- * subcommands of the "file" command.
- *
- * Copyright (c) 1996-1998 Sun Microsystems, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-#include "tclInt.h"
-#include "tclFileSystem.h"
-
-/*
- * Declarations for local functions defined in this file:
- */
-
-static int CopyRenameOneFile(Tcl_Interp *interp,
- Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr,
- int copyFlag, int force);
-static Tcl_Obj * FileBasename(Tcl_Interp *interp, Tcl_Obj *pathPtr);
-static int FileCopyRename(Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[], int copyFlag);
-static int FileForceOption(Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[], int *forcePtr);
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclFileRenameCmd
- *
- * This function implements the "rename" subcommand of the "file"
- * command. Filename arguments need to be translated to native format
- * before being passed to platform-specific code that implements rename
- * functionality.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * See the user documentation.
- *
- *---------------------------------------------------------------------------
- */
-
-int
-TclFileRenameCmd(
- ClientData clientData, /* Unused */
- Tcl_Interp *interp, /* Interp for error reporting or recursive
- * calls in the case of a tricky rename. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
-{
- return FileCopyRename(interp, objc, objv, 0);
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclFileCopyCmd
- *
- * This function implements the "copy" subcommand of the "file" command.
- * Filename arguments need to be translated to native format before being
- * passed to platform-specific code that implements copy functionality.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * See the user documentation.
- *
- *---------------------------------------------------------------------------
- */
-
-int
-TclFileCopyCmd(
- ClientData clientData, /* Unused */
- Tcl_Interp *interp, /* Used for error reporting or recursive calls
- * in the case of a tricky copy. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
-{
- return FileCopyRename(interp, objc, objv, 1);
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * FileCopyRename --
- *
- * Performs the work of TclFileRenameCmd and TclFileCopyCmd. See
- * comments for those functions.
- *
- * Results:
- * See above.
- *
- * Side effects:
- * See above.
- *
- *---------------------------------------------------------------------------
- */
-
-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;
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclFileMakeDirsCmd
- *
- * This function implements the "mkdir" subcommand of the "file" command.
- * Filename arguments need to be translated to native format before being
- * passed to platform-specific code that implements mkdir functionality.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * See the user documentation.
- *
- *----------------------------------------------------------------------
- */
-
-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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclFileDeleteCmd
- *
- * This function implements the "delete" subcommand of the "file"
- * command.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * See the user documentation.
- *
- *----------------------------------------------------------------------
- */
-
-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;
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * CopyRenameOneFile
- *
- * Copies or renames specified source file or directory hierarchy to the
- * specified target.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * Target is overwritten if the force flag is set. Attempting to
- * copy/rename a file onto a directory or a directory onto a file will
- * always result in an error.
- *
- *----------------------------------------------------------------------
- */
-
-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;
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * FileForceOption --
- *
- * Helps parse command line options for file commands that take the
- * "-force" and "--" options.
- *
- * Results:
- * The return value is how many arguments from argv were consumed by this
- * function, or -1 if there was an error parsing the options. If an error
- * occurred, an error message is left in the interp's result.
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------------
- */
-
-static int
-FileForceOption(
- Tcl_Interp *interp, /* Interp, for error return. */
- int objc, /* Number of arguments. */
- Tcl_Obj *const objv[], /* Argument strings. First command line
- * option, if it exists, begins at 0. */
- int *forcePtr) /* If the "-force" was specified, *forcePtr is
- * filled with 1, otherwise with 0. */
-{
- int force, i, idx;
- static const char *const options[] = {
- "-force", "--", NULL
- };
-
- force = 0;
- for (i = 0; i < objc; i++) {
- if (TclGetString(objv[i])[0] != '-') {
- break;
- }
- if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", TCL_EXACT,
- &idx) != TCL_OK) {
- return -1;
- }
- if (idx == 0 /* -force */) {
- force = 1;
- } else { /* -- */
- i++;
- break;
- }
- }
- *forcePtr = force;
- return i;
-}
-/*
- *---------------------------------------------------------------------------
- *
- * FileBasename --
- *
- * Given a path in either tcl format (with / separators), or in the
- * platform-specific format for the current platform, return all the
- * characters in the path after the last directory separator. But, if
- * path is the root directory, returns no characters.
- *
- * Results:
- * Returns the string object that represents the basename. If there is an
- * error, an error message is left in interp, and NULL is returned.
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------------
- */
-
-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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclFileAttrsCmd --
- *
- * Sets or gets the platform-specific attributes of a file. The objc-objv
- * points to the file name with the rest of the command line following.
- * This routine uses platform-specific tables of option strings and
- * callbacks. The callback to get the attributes take three parameters:
- * Tcl_Interp *interp; The interp to report errors with. Since
- * this is an object-based API, the object
- * form of the result should be used.
- * const char *fileName; This is extracted using
- * Tcl_TranslateFileName.
- * TclObj **attrObjPtrPtr; A new object to hold the attribute is
- * allocated and put here.
- * The first two parameters of the callback used to write out the
- * attributes are the same. The third parameter is:
- * const *attrObjPtr; A pointer to the object that has the new
- * attribute.
- * They both return standard TCL errors; if the routine to get an
- * attribute fails, no object is allocated and *attrObjPtrPtr is
- * unchanged.
- *
- * Results:
- * Standard TCL error.
- *
- * Side effects:
- * May set file attributes for the file name.
- *
- *----------------------------------------------------------------------
- */
-
-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", 0, &index) != TCL_OK) {
- goto end;
- }
- if (attributeStringsAllocated != NULL) {
- TclFreeIntRep(objv[0]);
- }
- 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", 0, &index) != TCL_OK) {
- goto end;
- }
- if (attributeStringsAllocated != NULL) {
- TclFreeIntRep(objv[i]);
- }
- 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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclFileLinkCmd --
- *
- * This function is invoked to process the "file link" Tcl command. See
- * the user documentation for details on what it does.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * May create a new link.
- *
- *----------------------------------------------------------------------
- */
-
-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;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclFileReadLinkCmd --
- *
- * This function is invoked to process the "file readlink" Tcl command.
- * See the user documentation for details on what it does.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-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;
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclFileTemporaryCmd
- *
- * This function implements the "tempfile" subcommand of the "file"
- * command.
- *
- * Results:
- * Returns a standard Tcl result.
- *
- * Side effects:
- * Creates a temporary file. Opens a channel to that file and puts the
- * name of that channel in the result. *Might* register suitable exit
- * handlers to ensure that the temporary file gets deleted. Might write
- * to a variable, so reentrancy is a potential issue.
- *
- *---------------------------------------------------------------------------
- */
-
-int
-TclFileTemporaryCmd(
- ClientData clientData,
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Tcl_Obj *nameVarObj = NULL; /* Variable to store the name of the temporary
- * file in. */
- Tcl_Obj *nameObj = NULL; /* Object that will contain the filename. */
- Tcl_Channel chan; /* The channel opened (RDWR) on the temporary
- * file, or NULL if there's an error. */
- Tcl_Obj *tempDirObj = NULL, *tempBaseObj = NULL, *tempExtObj = NULL;
- /* Pieces of template. Each piece is NULL if
- * it is omitted. The platform temporary file
- * engine might ignore some pieces. */
-
- if (objc < 1 || objc > 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "?nameVar? ?template?");
- return TCL_ERROR;
- }
-
- if (objc > 1) {
- nameVarObj = objv[1];
- TclNewObj(nameObj);
- }
- if (objc > 2) {
- int length;
- Tcl_Obj *templateObj = objv[2];
- const char *string = TclGetStringFromObj(templateObj, &length);
-
- /*
- * Treat an empty string as if it wasn't there.
- */
-
- if (length == 0) {
- goto makeTemporary;
- }
-
- /*
- * The template only gives a directory if there is a directory
- * separator in it.
- */
-
- if (strchr(string, '/') != NULL
- || (tclPlatform == TCL_PLATFORM_WINDOWS
- && strchr(string, '\\') != NULL)) {
- tempDirObj = TclPathPart(interp, templateObj, TCL_PATH_DIRNAME);
-
- /*
- * Only allow creation of temporary files in the native filesystem
- * since they are frequently used for integration with external
- * tools or system libraries. [Bug 2388866]
- */
-
- if (tempDirObj != NULL && Tcl_FSGetFileSystemForPath(tempDirObj)
- != &tclNativeFilesystem) {
- TclDecrRefCount(tempDirObj);
- tempDirObj = NULL;
- }
- }
-
- /*
- * The template only gives the filename if the last character isn't a
- * directory separator.
- */
-
- if (string[length-1] != '/' && (tclPlatform != TCL_PLATFORM_WINDOWS
- || string[length-1] != '\\')) {
- Tcl_Obj *tailObj = TclPathPart(interp, templateObj,
- TCL_PATH_TAIL);
-
- if (tailObj != NULL) {
- tempBaseObj = TclPathPart(interp, tailObj, TCL_PATH_ROOT);
- tempExtObj = TclPathPart(interp, tailObj, TCL_PATH_EXTENSION);
- TclDecrRefCount(tailObj);
- }
- }
- }
-
- /*
- * Convert empty parts of the template into unspecified parts.
- */
-
- if (tempDirObj && !TclGetString(tempDirObj)[0]) {
- TclDecrRefCount(tempDirObj);
- tempDirObj = NULL;
- }
- if (tempBaseObj && !TclGetString(tempBaseObj)[0]) {
- TclDecrRefCount(tempBaseObj);
- tempBaseObj = NULL;
- }
- if (tempExtObj && !TclGetString(tempExtObj)[0]) {
- TclDecrRefCount(tempExtObj);
- tempExtObj = NULL;
- }
-
- /*
- * Create and open the temporary file.
- */
-
- makeTemporary:
- chan = TclpOpenTemporaryFile(tempDirObj,tempBaseObj,tempExtObj, nameObj);
-
- /*
- * If we created pieces of template, get rid of them now.
- */
-
- if (tempDirObj) {
- TclDecrRefCount(tempDirObj);
- }
- if (tempBaseObj) {
- TclDecrRefCount(tempBaseObj);
- }
- if (tempExtObj) {
- TclDecrRefCount(tempExtObj);
- }
-
- /*
- * Deal with results.
- */
-
- if (chan == NULL) {
- if (nameVarObj) {
- TclDecrRefCount(nameObj);
- }
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't create temporary file: %s", Tcl_PosixError(interp)));
- return TCL_ERROR;
- }
- Tcl_RegisterChannel(interp, chan);
- if (nameVarObj != NULL) {
- if (Tcl_ObjSetVar2(interp, nameVarObj, NULL, nameObj,
- TCL_LEAVE_ERR_MSG) == NULL) {
- Tcl_UnregisterChannel(interp, chan);
- return TCL_ERROR;
- }
- }
- Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_GetChannelName(chan), -1));
- return TCL_OK;
-}
-
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */