summaryrefslogtreecommitdiffstats
path: root/generic/tclFCmd.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclFCmd.c')
-rw-r--r--generic/tclFCmd.c615
1 files changed, 335 insertions, 280 deletions
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index d5e7005..3c79e85 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -1,25 +1,25 @@
/*
* tclFCmd.c
*
- * This file implements the generic portion of file manipulation
- * subcommands of the "file" command.
+ * 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.
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclFCmd.c,v 1.34 2005/06/13 08:32:05 vincentdarley Exp $
+ * RCS: @(#) $Id: tclFCmd.c,v 1.35 2005/07/24 22:56:43 dkf Exp $
*/
#include "tclInt.h"
/*
- * Declarations for local procedures defined in this file:
+ * Declarations for local functions defined in this file:
*/
static int CopyRenameOneFile _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr,
+ Tcl_Obj *srcPathPtr, Tcl_Obj *destPathPtr,
int copyFlag, int force));
static Tcl_Obj * FileBasename _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr));
@@ -33,10 +33,10 @@ static int FileForceOption _ANSI_ARGS_((Tcl_Interp *interp,
*
* TclFileRenameCmd
*
- * This procedure 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.
+ * 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.
@@ -61,10 +61,9 @@ TclFileRenameCmd(interp, objc, objv)
*
* TclFileCopyCmd
*
- * This procedure 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.
+ * 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.
@@ -89,8 +88,8 @@ TclFileCopyCmd(interp, objc, objv)
*
* FileCopyRename --
*
- * Performs the work of TclFileRenameCmd and TclFileCopyCmd.
- * See comments for those procedures.
+ * Performs the work of TclFileRenameCmd and TclFileCopyCmd. See
+ * comments for those functions.
*
* Results:
* See above.
@@ -106,11 +105,11 @@ FileCopyRename(interp, objc, objv, copyFlag)
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,
+ int copyFlag; /* If non-zero, copy source(s). Otherwise,
* rename them. */
{
int i, result, force;
- Tcl_StatBuf statBuf;
+ Tcl_StatBuf statBuf;
Tcl_Obj *target;
i = FileForceOption(interp, objc - 2, objv + 2, &force);
@@ -119,9 +118,9 @@ FileCopyRename(interp, objc, objv, copyFlag)
}
i += 2;
if ((objc - i) < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]),
- " ?options? source ?source ...? target\"",
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ TclGetString(objv[0]), " ", TclGetString(objv[1]),
+ " ?options? source ?source ...? target\"",
(char *) NULL);
return TCL_ERROR;
}
@@ -151,14 +150,14 @@ FileCopyRename(interp, objc, objv, copyFlag)
Tcl_PosixError(interp);
Tcl_AppendResult(interp, "error ",
((copyFlag) ? "copying" : "renaming"), ": target \"",
- Tcl_GetString(target), "\" is not a directory",
+ TclGetString(target), "\" is not a directory",
(char *) NULL);
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.
+ * 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,
@@ -166,17 +165,17 @@ FileCopyRename(interp, objc, objv, copyFlag)
}
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.
+ * 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++) {
+ for ( ; i<objc-1 ; i++) {
Tcl_Obj *jargv[2];
Tcl_Obj *source, *newFileName;
Tcl_Obj *temp;
-
+
source = FileBasename(interp, objv[i]);
if (source == NULL) {
result = TCL_ERROR;
@@ -205,10 +204,9 @@ FileCopyRename(interp, objc, objv, copyFlag)
*
* TclFileMakeDirsCmd
*
- * This procedure 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.
+ * 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.
@@ -249,10 +247,10 @@ TclFileMakeDirsCmd(interp, objc, objv)
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.
+ * 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) {
@@ -262,26 +260,28 @@ TclFileMakeDirsCmd(interp, objc, objv)
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.
+ /*
+ * 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.
+ * condition with another process trying to create the same
+ * subdirectory.
*/
+
if (errno == EEXIST) {
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.
+ && 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;
@@ -292,19 +292,22 @@ TclFileMakeDirsCmd(interp, objc, objv)
goto done;
}
}
-
- /* Forget about this sub-path */
+
+ /*
+ * Forget about this sub-path.
+ */
+
Tcl_DecrRefCount(target);
target = NULL;
}
Tcl_DecrRefCount(split);
split = NULL;
}
-
- done:
+
+ done:
if (errfile != NULL) {
Tcl_AppendResult(interp, "can't create directory \"",
- Tcl_GetString(errfile), "\": ", Tcl_PosixError(interp),
+ TclGetString(errfile), "\": ", Tcl_PosixError(interp),
(char *) NULL);
result = TCL_ERROR;
}
@@ -322,8 +325,8 @@ TclFileMakeDirsCmd(interp, objc, objv)
*
* TclFileDeleteCmd
*
- * This procedure implements the "delete" subcommand of the "file"
- * command.
+ * This function implements the "delete" subcommand of the "file"
+ * command.
*
* Results:
* A standard Tcl result.
@@ -343,15 +346,15 @@ TclFileDeleteCmd(interp, objc, objv)
int i, force, result;
Tcl_Obj *errfile;
Tcl_Obj *errorBuffer = NULL;
-
+
i = FileForceOption(interp, objc - 2, objv + 2, &force);
if (i < 0) {
return TCL_ERROR;
}
i += 2;
if ((objc - i) < 1) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- Tcl_GetString(objv[0]), " ", Tcl_GetString(objv[1]),
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ TclGetString(objv[0]), " ", TclGetString(objv[1]),
" ?options? file ?file ...?\"", (char *) NULL);
return TCL_ERROR;
}
@@ -374,34 +377,39 @@ TclFileDeleteCmd(interp, objc, objv)
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
+ * 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.
+ /*
+ * 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_AppendResult(interp, "error deleting \"",
- Tcl_GetString(objv[i]),
- "\": directory not empty", (char *) NULL);
+ Tcl_AppendResult(interp, "error deleting \"",
+ TclGetString(objv[i]), "\": directory not empty",
+ (char *) NULL);
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 */
+
+ /*
+ * FS supposed to check between translated objv and errfile.
+ */
+
if (Tcl_FSEqualPaths(objv[i], errfile)) {
errfile = objv[i];
}
@@ -409,32 +417,34 @@ TclFileDeleteCmd(interp, objc, objv)
} 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.
+
+ /*
+ * 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
+ /*
+ * We try to accomodate poor error results from our Tcl_FS calls.
*/
- Tcl_AppendResult(interp, "error deleting unknown file: ",
+
+ Tcl_AppendResult(interp, "error deleting unknown file: ",
Tcl_PosixError(interp), (char *) NULL);
} else {
- Tcl_AppendResult(interp, "error deleting \"",
- Tcl_GetString(errfile), "\": ",
- Tcl_PosixError(interp), (char *) NULL);
+ Tcl_AppendResult(interp, "error deleting \"",
+ TclGetString(errfile), "\": ", Tcl_PosixError(interp),
+ (char *) NULL);
}
- }
- done:
+ }
+
+ done:
if (errorBuffer != NULL) {
Tcl_DecrRefCount(errorBuffer);
}
@@ -446,37 +456,37 @@ TclFileDeleteCmd(interp, objc, objv)
*
* CopyRenameOneFile
*
- * Copies or renames specified source file or directory hierarchy
- * to the specified target.
+ * 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.
+ * 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(interp, source, target, copyFlag, force)
+CopyRenameOneFile(interp, source, target, copyFlag, force)
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. */
+ 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. Otherwise, error if target already
* exists. */
{
int result;
Tcl_Obj *errfile, *errorBuffer;
- /* If source is a link, then this is the real file/directory */
- Tcl_Obj *actualSource = NULL;
+ 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) {
@@ -485,16 +495,15 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
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.
+ * 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) {
@@ -513,52 +522,52 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
goto done;
}
- /*
- * Prevent copying or renaming a file onto itself. Under Windows,
- * stat always returns 0 for st_ino. However, the Windows-specific
- * code knows how to deal with copying or renaming a file on top of
- * itself. It might be a good idea to write a stat that worked.
- */
-
- 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;
- }
- }
+ /*
+ * Prevent copying or renaming a file onto itself. Under Windows, stat
+ * always returns 0 for st_ino. However, the Windows-specific code
+ * knows how to deal with copying or renaming a file on top of itself.
+ * It might be a good idea to write a stat that worked.
+ */
+
+ 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;
+ }
+ }
/*
- * 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.
+ * 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)) {
+ && !S_ISDIR(targetStatBuf.st_mode)) {
errno = EISDIR;
- Tcl_AppendResult(interp, "can't overwrite file \"",
- Tcl_GetString(target), "\" with directory \"",
- Tcl_GetString(source), "\"", (char *) NULL);
+ Tcl_AppendResult(interp, "can't overwrite file \"",
+ TclGetString(target), "\" with directory \"",
+ TclGetString(source), "\"", (char *) NULL);
goto done;
}
if (!S_ISDIR(sourceStatBuf.st_mode)
- && S_ISDIR(targetStatBuf.st_mode)) {
+ && S_ISDIR(targetStatBuf.st_mode)) {
errno = EISDIR;
- Tcl_AppendResult(interp, "can't overwrite directory \"",
- Tcl_GetString(target), "\" with file \"",
- Tcl_GetString(source), "\"", (char *) NULL);
+ Tcl_AppendResult(interp, "can't overwrite directory \"",
+ TclGetString(target), "\" with file \"",
+ TclGetString(source), "\"", (char *) NULL);
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.
+
+ /*
+ * 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 = Tcl_NewStringObj("u+w",-1);
int index;
@@ -575,68 +584,76 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
if (result == TCL_OK) {
goto done;
}
-
+
if (errno == EINVAL) {
- Tcl_AppendResult(interp, "error renaming \"",
- Tcl_GetString(source), "\" to \"",
- Tcl_GetString(target), "\": trying to rename a volume or ",
+ Tcl_AppendResult(interp, "error renaming \"",
+ TclGetString(source), "\" to \"", TclGetString(target),
+ "\": trying to rename a volume or ",
"move a directory into itself", (char *) NULL);
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.
+ * 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.
+
+ /*
+ * 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.
+ /*
+ * 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_AppendResult(interp,
- "error copying \"", Tcl_GetString(source),
+ /*
+ * Actual file doesn't exist.
+ */
+
+ Tcl_AppendResult(interp, "error copying \"", TclGetString(source),
"\": the target of this link doesn't exist",
(char *) NULL);
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
+
+ /*
+ * 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;
}
@@ -647,9 +664,16 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
Tcl_DecrRefCount(actualSource);
actualSource = path;
counter++;
- /* Arbitrary limit of 20 links to follow */
+
+ /*
+ * Arbitrary limit of 20 links to follow.
+ */
+
if (counter > 20) {
- /* Too many links */
+ /*
+ * Too many links.
+ */
+
Tcl_SetErrno(EMLINK);
errfile = source;
goto done;
@@ -665,33 +689,34 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
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.
+ * cross-filesystem copy. We do this through our Tcl library.
*/
+
Tcl_Obj *copyCommand = Tcl_NewListObj(0,NULL);
Tcl_IncrRefCount(copyCommand);
- Tcl_ListObjAppendElement(interp, copyCommand,
+ Tcl_ListObjAppendElement(interp, copyCommand,
Tcl_NewStringObj("::tcl::CopyDirectory",-1));
if (copyFlag) {
- Tcl_ListObjAppendElement(interp, copyCommand,
- Tcl_NewStringObj("copying",-1));
+ Tcl_ListObjAppendElement(interp, copyCommand,
+ Tcl_NewStringObj("copying",-1));
} else {
- Tcl_ListObjAppendElement(interp, copyCommand,
- Tcl_NewStringObj("renaming",-1));
+ Tcl_ListObjAppendElement(interp, copyCommand,
+ Tcl_NewStringObj("renaming",-1));
}
Tcl_ListObjAppendElement(interp, copyCommand, source);
Tcl_ListObjAppendElement(interp, copyCommand, target);
- result = Tcl_EvalObjEx(interp, copyCommand,
- TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
+ 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
+ /*
+ * 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 {
@@ -709,19 +734,22 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
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
+ /*
+ * 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,
- * if it failed, may have put an error message in place.
- * (Ideally we would prefer not to pass an interpreter in
- * above, but the channel IO code used by
- * TclCrossFilesystemCopy currently requires one)
+
+ /*
+ * We now need to reset the result, because the above call, if it
+ * failed, may have put an error message in place. (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);
}
}
@@ -740,31 +768,30 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
}
}
if (result != TCL_OK) {
- Tcl_AppendResult(interp, "can't unlink \"",
- Tcl_GetString(errfile), "\": ",
- Tcl_PosixError(interp), (char *) NULL);
+ Tcl_AppendResult(interp, "can't unlink \"", TclGetString(errfile),
+ "\": ", Tcl_PosixError(interp), (char *) NULL);
errfile = NULL;
}
}
-
- done:
+
+ done:
if (errfile != NULL) {
- Tcl_AppendResult(interp,
+ Tcl_AppendResult(interp,
((copyFlag) ? "error copying \"" : "error renaming \""),
- Tcl_GetString(source), (char *) NULL);
+ TclGetString(source), (char *) NULL);
if (errfile != source) {
- Tcl_AppendResult(interp, "\" to \"", Tcl_GetString(target),
- (char *) NULL);
+ Tcl_AppendResult(interp, "\" to \"", TclGetString(target),
+ (char *) NULL);
if (errfile != target) {
- Tcl_AppendResult(interp, "\": \"", Tcl_GetString(errfile),
- (char *) NULL);
+ Tcl_AppendResult(interp, "\": \"", TclGetString(errfile),
+ (char *) NULL);
}
}
Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp),
(char *) NULL);
}
if (errorBuffer != NULL) {
- Tcl_DecrRefCount(errorBuffer);
+ Tcl_DecrRefCount(errorBuffer);
}
if (actualSource != NULL) {
Tcl_DecrRefCount(actualSource);
@@ -777,14 +804,13 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
*
* FileForceOption --
*
- * Helps parse command line options for file commands that take
- * the "-force" and "--" options.
+ * 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.
+ * 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.
@@ -798,23 +824,23 @@ FileForceOption(interp, objc, objv, forcePtr)
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 *forcePtr; /* If the "-force" was specified, *forcePtr is
+ * filled with 1, otherwise with 0. */
{
int force, i;
-
+
force = 0;
for (i = 0; i < objc; i++) {
- if (Tcl_GetString(objv[i])[0] != '-') {
+ if (TclGetString(objv[i])[0] != '-') {
break;
}
- if (strcmp(Tcl_GetString(objv[i]), "-force") == 0) {
+ if (strcmp(TclGetString(objv[i]), "-force") == 0) {
force = 1;
- } else if (strcmp(Tcl_GetString(objv[i]), "--") == 0) {
+ } else if (strcmp(TclGetString(objv[i]), "--") == 0) {
i++;
break;
} else {
- Tcl_AppendResult(interp, "bad option \"", Tcl_GetString(objv[i]),
+ Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[i]),
"\": should be -force or --", (char *)NULL);
return -1;
}
@@ -829,13 +855,12 @@ FileForceOption(interp, objc, objv, forcePtr)
*
* 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.
+ * 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.
+ * 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.
@@ -851,12 +876,12 @@ FileBasename(interp, pathPtr)
int objc;
Tcl_Obj *splitPtr;
Tcl_Obj *resultPtr = NULL;
-
+
splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
Tcl_IncrRefCount(splitPtr);
-
+
if (objc != 0) {
- if ((objc == 1) && (*Tcl_GetString(pathPtr) == '~')) {
+ if ((objc == 1) && (*TclGetString(pathPtr) == '~')) {
Tcl_DecrRefCount(splitPtr);
if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
return NULL;
@@ -873,7 +898,7 @@ FileBasename(interp, pathPtr)
if (objc > 0) {
Tcl_ListObjIndex(NULL, splitPtr, objc-1, &resultPtr);
if ((objc == 1) &&
- (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) {
+ (Tcl_FSGetPathType(resultPtr) != TCL_PATH_RELATIVE)) {
resultPtr = NULL;
}
}
@@ -891,33 +916,31 @@ FileBasename(interp, pathPtr)
*
* 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.
+ * 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.
+ * 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.
+ * 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.
+ * Standard TCL error.
*
* Side effects:
- * May set file attributes for the file name.
- *
+ * May set file attributes for the file name.
+ *
*----------------------------------------------------------------------
*/
@@ -932,7 +955,7 @@ TclFileAttrsCmd(interp, objc, objv)
Tcl_Obj* objStrings = NULL;
int numObjStrings = -1;
Tcl_Obj *filePtr;
-
+
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv,
"name ?option? ?value? ?option value ...?");
@@ -943,39 +966,49 @@ TclFileAttrsCmd(interp, objc, objv)
if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) {
return TCL_ERROR;
}
-
+
objc -= 3;
objv += 3;
result = TCL_ERROR;
Tcl_SetErrno(0);
+
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
+ /*
+ * There was an error, probably that the filePtr is not
+ * accepted by any filesystem
*/
Tcl_AppendResult(interp, "could not read \"",
- Tcl_GetString(filePtr), "\": ", Tcl_PosixError(interp),
+ TclGetString(filePtr), "\": ", Tcl_PosixError(interp),
(char *) NULL);
return TCL_ERROR;
}
goto end;
}
- /* We own the object now */
+
+ /*
+ * We own the object now.
+ */
+
Tcl_IncrRefCount(objStrings);
- /* Use objStrings as a list object */
+
+ /*
+ * Use objStrings as a list object.
+ */
+
if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) {
goto end;
}
attributeStrings = (CONST char **)
- ckalloc ((1+numObjStrings) * sizeof(char*));
+ ckalloc((1+numObjStrings) * sizeof(char*));
for (index = 0; index < numObjStrings; index++) {
Tcl_ListObjIndex(interp, objStrings, index, &objPtr);
- attributeStrings[index] = Tcl_GetString(objPtr);
+ attributeStrings[index] = TclGetString(objPtr);
}
attributeStrings[index] = NULL;
}
@@ -986,28 +1019,39 @@ TclFileAttrsCmd(interp, objc, objv)
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);
+ /*
+ * 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++;
+ 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 */
+ /*
+ * Error: no valid attributes found.
+ */
+
Tcl_DecrRefCount(listPtr);
goto end;
}
+
Tcl_SetObjResult(interp, listPtr);
} else if (objc == 1) {
/*
@@ -1018,9 +1062,9 @@ TclFileAttrsCmd(interp, objc, objv)
Tcl_Obj *objPtr = NULL;
if (numObjStrings == 0) {
- Tcl_AppendResult(interp, "bad option \"",
- Tcl_GetString(objv[0]), "\", there are no file attributes"
- " in this filesystem.", (char *) NULL);
+ Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]),
+ "\", there are no file attributes in this filesystem.",
+ (char *) NULL);
goto end;
}
@@ -1039,11 +1083,11 @@ TclFileAttrsCmd(interp, objc, objv)
*/
int i, index;
-
+
if (numObjStrings == 0) {
- Tcl_AppendResult(interp, "bad option \"",
- Tcl_GetString(objv[0]), "\", there are no file attributes"
- " in this filesystem.", (char *) NULL);
+ Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]),
+ "\", there are no file attributes in this filesystem.",
+ (char *) NULL);
goto end;
}
@@ -1054,8 +1098,7 @@ TclFileAttrsCmd(interp, objc, objv)
}
if (i + 1 == objc) {
Tcl_AppendResult(interp, "value for \"",
- Tcl_GetString(objv[i]), "\" missing",
- (char *) NULL);
+ TclGetString(objv[i]), "\" missing", (char *) NULL);
goto end;
}
if (Tcl_FSFileAttrsSet(interp, index, filePtr,
@@ -1066,17 +1109,29 @@ TclFileAttrsCmd(interp, objc, objv)
}
result = TCL_OK;
- end:
+ end:
if (numObjStrings != -1) {
- /* Free up the array we allocated */
+ /*
+ * Free up the array we allocated.
+ */
+
ckfree((char*)attributeStrings);
- /*
- * We don't need this object that was passed to us
- * any more.
+
+ /*
+ * We don't need this object that was passed to us any more.
*/
+
if (objStrings != NULL) {
Tcl_DecrRefCount(objStrings);
}
}
return result;
}
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * End:
+ */