summaryrefslogtreecommitdiffstats
path: root/generic/tclFCmd.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclFCmd.c')
-rw-r--r--generic/tclFCmd.c902
1 files changed, 155 insertions, 747 deletions
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index 42f4c5a..c52cd1e 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -4,14 +4,13 @@
* This file implements the generic portion of file manipulation
* subcommands of the "file" command.
*
- * Copyright © 1996-1998 Sun Microsystems, Inc.
+ * 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:
@@ -22,9 +21,9 @@ static int CopyRenameOneFile(Tcl_Interp *interp,
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);
+ int objc, Tcl_Obj *CONST objv[], int copyFlag);
static int FileForceOption(Tcl_Interp *interp,
- int objc, Tcl_Obj *const objv[], int *forcePtr);
+ int objc, Tcl_Obj *CONST objv[], int *forcePtr);
/*
*---------------------------------------------------------------------------
@@ -47,11 +46,10 @@ static int FileForceOption(Tcl_Interp *interp,
int
TclFileRenameCmd(
- TCL_UNUSED(ClientData),
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. */
+ Tcl_Obj *CONST objv[]) /* Argument strings passed to Tcl_FileCmd. */
{
return FileCopyRename(interp, objc, objv, 0);
}
@@ -76,11 +74,10 @@ TclFileRenameCmd(
int
TclFileCopyCmd(
- TCL_UNUSED(ClientData),
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. */
+ Tcl_Obj *CONST objv[]) /* Argument strings passed to Tcl_FileCmd. */
{
return FileCopyRename(interp, objc, objv, 1);
}
@@ -106,7 +103,7 @@ 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. */
+ Tcl_Obj *CONST objv[], /* Argument strings passed to Tcl_FileCmd. */
int copyFlag) /* If non-zero, copy source(s). Otherwise,
* rename them. */
{
@@ -114,20 +111,22 @@ FileCopyRename(
Tcl_StatBuf statBuf;
Tcl_Obj *target;
- i = FileForceOption(interp, objc - 1, objv + 1, &force);
+ i = FileForceOption(interp, objc - 2, objv + 2, &force);
if (i < 0) {
return TCL_ERROR;
}
- i++;
+ i += 2;
if ((objc - i) < 2) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "?-option value ...? source ?source ...? target");
+ Tcl_AppendResult(interp, "wrong # args: should be \"",
+ TclGetString(objv[0]), " ", TclGetString(objv[1]),
+ " ?options? source ?source ...? target\"", NULL);
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.
+ * 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];
@@ -147,9 +146,9 @@ FileCopyRename(
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)));
+ Tcl_AppendResult(interp, "error ",
+ (copyFlag ? "copying" : "renaming"), ": target \"",
+ TclGetString(target), "\" is not a directory", NULL);
result = TCL_ERROR;
} else {
/*
@@ -172,6 +171,7 @@ FileCopyRename(
for ( ; i<objc-1 ; i++) {
Tcl_Obj *jargv[2];
Tcl_Obj *source, *newFileName;
+ Tcl_Obj *temp;
source = FileBasename(interp, objv[i]);
if (source == NULL) {
@@ -180,11 +180,13 @@ FileCopyRename(
}
jargv[0] = objv[objc - 1];
jargv[1] = source;
- newFileName = TclJoinPath(2, jargv, 1);
+ temp = Tcl_NewListObj(2, jargv);
+ newFileName = Tcl_FSJoinPath(temp, -1);
Tcl_IncrRefCount(newFileName);
result = CopyRenameOneFile(interp, objv[i], newFileName, copyFlag,
force);
Tcl_DecrRefCount(newFileName);
+ Tcl_DecrRefCount(temp);
Tcl_DecrRefCount(source);
if (result == TCL_ERROR) {
@@ -214,25 +216,26 @@ FileCopyRename(
int
TclFileMakeDirsCmd(
- TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Used for error reporting. */
int objc, /* Number of arguments */
- Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
+ Tcl_Obj *CONST objv[]) /* Argument strings passed to Tcl_FileCmd. */
{
- Tcl_Obj *errfile = NULL;
+ Tcl_Obj *errfile;
int result, i, j, pobjc;
Tcl_Obj *split = NULL;
Tcl_Obj *target = NULL;
Tcl_StatBuf statBuf;
+ errfile = NULL;
+
result = TCL_OK;
- for (i = 1; i < objc; i++) {
+ for (i = 2; i < objc; i++) {
if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
result = TCL_ERROR;
break;
}
- split = Tcl_FSSplitPath(objv[i], &pobjc);
+ split = Tcl_FSSplitPath(objv[i],&pobjc);
Tcl_IncrRefCount(split);
if (pobjc == 0) {
errno = ENOENT;
@@ -240,13 +243,9 @@ TclFileMakeDirsCmd(
break;
}
for (j = 0; j < pobjc; j++) {
- int errCount = 2;
-
target = Tcl_FSJoinPath(split, j + 1);
Tcl_IncrRefCount(target);
- createDir:
-
/*
* Call Tcl_FSStat() so that if target is a symlink that points to
* a directory we will create subdirectories in that directory.
@@ -274,24 +273,24 @@ TclFileMakeDirsCmd(
*/
if (errno == EEXIST) {
- /* Be aware other workers could delete it immediately after
- * creation, so give this worker still one chance (repeat once),
- * see [270f78ca95] for description of the race-condition.
- * Don't repeat the create always (to avoid endless loop). */
- if (--errCount > 0) {
- goto createDir;
+ 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;
}
- /* Already tried, with delete in-between directly after
- * creation, so just continue (assume created successful). */
- goto nextPart;
+ } else {
+ errfile = target;
+ goto done;
}
-
- /* return with error */
- errfile = target;
- goto done;
}
- nextPart:
/*
* Forget about this sub-path.
*/
@@ -305,9 +304,8 @@ TclFileMakeDirsCmd(
done:
if (errfile != NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't create directory \"%s\": %s",
- TclGetString(errfile), Tcl_PosixError(interp)));
+ Tcl_AppendResult(interp, "can't create directory \"",
+ TclGetString(errfile), "\": ", Tcl_PosixError(interp), NULL);
result = TCL_ERROR;
}
if (split != NULL) {
@@ -338,24 +336,30 @@ TclFileMakeDirsCmd(
int
TclFileDeleteCmd(
- TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* Used for error reporting */
int objc, /* Number of arguments */
- Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
+ 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);
+ 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 \"",
+ TclGetString(objv[0]), " ", TclGetString(objv[1]),
+ " ?options? file ?file ...?\"", NULL);
+ return TCL_ERROR;
+ }
errfile = NULL;
result = TCL_OK;
- for (i++ ; i < objc; i++) {
+ for ( ; i < objc; i++) {
Tcl_StatBuf statBuf;
errfile = objv[i];
@@ -369,7 +373,14 @@ TclFileDeleteCmd(
*/
if (Tcl_FSLstat(objv[i], &statBuf) != 0) {
- result = TCL_ERROR;
+ /*
+ * 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
@@ -379,9 +390,9 @@ TclFileDeleteCmd(
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_AppendResult(interp, "error deleting \"",
+ TclGetString(objv[i]), "\": directory not empty",
+ NULL);
Tcl_PosixError(interp);
goto done;
}
@@ -405,36 +416,28 @@ TclFileDeleteCmd(
}
if (result != TCL_OK) {
+ result = TCL_ERROR;
/*
- * Avoid possible race condition (file/directory deleted after call
- * of lstat), so bypass ENOENT because not an error, just a no-op
- */
- if (errno == ENOENT) {
- result = TCL_OK;
- continue;
- }
- /*
* It is important that we break on error, otherwise we might end
* up owning reference counts on numerous errorBuffers.
*/
- result = TCL_ERROR;
+
break;
}
}
if (result != TCL_OK) {
if (errfile == NULL) {
/*
- * We try to accommodate poor error results from our Tcl_FS calls.
+ * 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)));
+ Tcl_AppendResult(interp, "error deleting unknown file: ",
+ Tcl_PosixError(interp), NULL);
} else {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "error deleting \"%s\": %s",
- TclGetString(errfile), Tcl_PosixError(interp)));
+ Tcl_AppendResult(interp, "error deleting \"",
+ TclGetString(errfile), "\": ", Tcl_PosixError(interp),
+ NULL);
}
}
@@ -523,7 +526,7 @@ CopyRenameOneFile(
* 16 bits and we get collisions. See bug #2015723.
*/
-#if !defined(_WIN32) && !defined(__CYGWIN__)
+#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)) {
@@ -543,17 +546,17 @@ CopyRenameOneFile(
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)));
+ Tcl_AppendResult(interp, "can't overwrite file \"",
+ TclGetString(target), "\" with directory \"",
+ TclGetString(source), "\"", NULL);
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)));
+ Tcl_AppendResult(interp, "can't overwrite directory \"",
+ TclGetString(target), "\" with file \"",
+ TclGetString(source), "\"", NULL);
goto done;
}
@@ -584,10 +587,10 @@ CopyRenameOneFile(
}
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)));
+ Tcl_AppendResult(interp, "error renaming \"",
+ TclGetString(source), "\" to \"", TclGetString(target),
+ "\": trying to rename a volume or "
+ "move a directory into itself", NULL);
goto done;
} else if (errno != EXDEV) {
errfile = target;
@@ -631,9 +634,8 @@ CopyRenameOneFile(
* Actual file doesn't exist.
*/
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "error copying \"%s\": the target of this link doesn't"
- " exist", TclGetString(source)));
+ Tcl_AppendResult(interp, "error copying \"", TclGetString(source),
+ "\": the target of this link doesn't exist", NULL);
goto done;
} else {
int counter = 0;
@@ -753,7 +755,6 @@ CopyRenameOneFile(
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;
}
@@ -765,27 +766,23 @@ CopyRenameOneFile(
}
}
if (result != TCL_OK) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf("can't unlink \"%s\": %s",
- TclGetString(errfile), Tcl_PosixError(interp)));
+ Tcl_AppendResult(interp, "can't unlink \"", TclGetString(errfile),
+ "\": ", Tcl_PosixError(interp), NULL);
errfile = NULL;
}
}
done:
if (errfile != NULL) {
- Tcl_Obj *errorMsg = Tcl_ObjPrintf("error %s \"%s\"",
- (copyFlag ? "copying" : "renaming"), TclGetString(source));
-
+ Tcl_AppendResult(interp, "error ", (copyFlag ? "copying" : "renaming"),
+ " \"", TclGetString(source), NULL);
if (errfile != source) {
- Tcl_AppendPrintfToObj(errorMsg, " to \"%s\"",
- TclGetString(target));
+ Tcl_AppendResult(interp, "\" to \"", TclGetString(target), NULL);
if (errfile != target) {
- Tcl_AppendPrintfToObj(errorMsg, ": \"%s\"",
- TclGetString(errfile));
+ Tcl_AppendResult(interp, "\": \"", TclGetString(errfile),NULL);
}
}
- Tcl_AppendPrintfToObj(errorMsg, ": %s", Tcl_PosixError(interp));
- Tcl_SetObjResult(interp, errorMsg);
+ Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), NULL);
}
if (errorBuffer != NULL) {
Tcl_DecrRefCount(errorBuffer);
@@ -819,30 +816,27 @@ static int
FileForceOption(
Tcl_Interp *interp, /* Interp, for error return. */
int objc, /* Number of arguments. */
- Tcl_Obj *const objv[], /* Argument strings. First command line
+ 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
- };
+ int force, i;
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 */) {
+ if (strcmp(TclGetString(objv[i]), "-force") == 0) {
force = 1;
- } else { /* -- */
+ } else if (strcmp(TclGetString(objv[i]), "--") == 0) {
i++;
break;
+ } else {
+ Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[i]),
+ "\": should be -force or --", NULL);
+ return -1;
}
}
*forcePtr = force;
@@ -904,7 +898,7 @@ FileBasename(
}
}
if (resultPtr == NULL) {
- TclNewObj(resultPtr);
+ resultPtr = Tcl_NewObj();
}
Tcl_IncrRefCount(resultPtr);
Tcl_DecrRefCount(splitPtr);
@@ -923,13 +917,13 @@ FileBasename(
* 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
+ * 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
+ * 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
@@ -946,37 +940,32 @@ FileBasename(
int
TclFileAttrsCmd(
- TCL_UNUSED(ClientData),
Tcl_Interp *interp, /* The interpreter for error reporting. */
int objc, /* Number of command line arguments. */
- Tcl_Obj *const objv[]) /* The command line objects. */
+ 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;
+ CONST char ** attributeStrings;
+ Tcl_Obj* objStrings = NULL;
+ int numObjStrings = -1, didAlloc = 0;
Tcl_Obj *filePtr;
- if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "name ?-option value ...?");
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "name ?option? ?value? ?option value ...?");
return TCL_ERROR;
}
- filePtr = objv[1];
+ filePtr = objv[2];
if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) {
- return TCL_ERROR;
+ return TCL_ERROR;
}
- objc -= 2;
- objv += 2;
+ objc -= 3;
+ objv += 3;
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;
@@ -988,10 +977,9 @@ TclFileAttrsCmd(
* 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)));
+ Tcl_AppendResult(interp, "could not read \"",
+ TclGetString(filePtr), "\": ", Tcl_PosixError(interp),
+ NULL);
}
return TCL_ERROR;
}
@@ -1006,27 +994,21 @@ TclFileAttrsCmd(
* Use objStrings as a list object.
*/
- if (TclListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) {
+ if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) {
goto end;
}
- attributeStringsAllocated = (const char **)
- TclStackAlloc(interp, (1+numObjStrings) * sizeof(char *));
+ attributeStrings = (CONST char **) TclStackAlloc(interp,
+ (1+numObjStrings) * sizeof(char*));
+ didAlloc = 1;
for (index = 0; index < numObjStrings; index++) {
Tcl_ListObjIndex(interp, objStrings, index, &objPtr);
- attributeStringsAllocated[index] = TclGetString(objPtr);
+ attributeStrings[index] = TclGetString(objPtr);
}
- attributeStringsAllocated[index] = NULL;
- attributeStrings = attributeStringsAllocated;
+ attributeStrings[index] = NULL;
} 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.
@@ -1067,7 +1049,7 @@ TclFileAttrsCmd(
goto end;
}
- Tcl_SetObjResult(interp, listPtr);
+ Tcl_SetObjResult(interp, listPtr);
} else if (objc == 1) {
/*
* Get one attribute.
@@ -1077,17 +1059,20 @@ TclFileAttrsCmd(
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", (void *)NULL);
+ Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]),
+ "\", there are no file attributes in this filesystem.",
+ NULL);
goto end;
}
if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings,
- "option", TCL_INDEX_TEMP_TABLE, &index) != TCL_OK) {
+ "option", 0, &index) != TCL_OK) {
goto end;
}
+ if (didAlloc) {
+ TclFreeIntRep(objv[0]);
+ objv[0]->typePtr = NULL;
+ }
if (Tcl_FSFileAttrsGet(interp, index, filePtr,
&objPtr) != TCL_OK) {
goto end;
@@ -1101,628 +1086,51 @@ TclFileAttrsCmd(
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", (void *)NULL);
+ Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]),
+ "\", there are no file attributes in this filesystem.",
+ NULL);
goto end;
}
- for (i = 0; i < objc ; i += 2) {
- if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
- "option", TCL_INDEX_TEMP_TABLE, &index) != TCL_OK) {
+ for (i = 0; i < objc ; i += 2) {
+ if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
+ "option", 0, &index) != TCL_OK) {
goto end;
+ }
+ if (didAlloc) {
+ TclFreeIntRep(objv[i]);
+ objv[i]->typePtr = NULL;
}
if (i + 1 == objc) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "value for \"%s\" missing", TclGetString(objv[i])));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FATTR",
- "NOVALUE", (void *)NULL);
+ Tcl_AppendResult(interp, "value for \"",
+ TclGetString(objv[i]), "\" missing", NULL);
goto end;
}
- if (Tcl_FSFileAttrsSet(interp, index, filePtr,
- objv[i + 1]) != TCL_OK) {
+ 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(
- TCL_UNUSED(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(
- TCL_UNUSED(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(
- TCL_UNUSED(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;
- }
- }
-
+ if (didAlloc) {
/*
- * The template only gives the filename if the last character isn't a
- * directory separator.
+ * Free up the array we allocated.
*/
- 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;
+ TclStackFree(interp, (void *)attributeStrings);
}
- /*
- * 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;
-}
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclFileTempDirCmd --
- *
- * This function implements the "tempdir" subcommand of the "file"
- * command.
- *
- * Results:
- * Returns a standard Tcl result.
- *
- * Side effects:
- * Creates a temporary directory.
- *
- *---------------------------------------------------------------------------
- */
-
-int
-TclFileTempDirCmd(
- TCL_UNUSED(ClientData),
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Tcl_Obj *dirNameObj; /* Object that will contain the directory
- * name. */
- Tcl_Obj *baseDirObj = NULL, *nameBaseObj = 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 > 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "?template?");
- return TCL_ERROR;
- }
-
- if (objc > 1) {
- int length;
- Tcl_Obj *templateObj = objv[1];
- const char *string = TclGetStringFromObj(templateObj, &length);
- const int onWindows = (tclPlatform == TCL_PLATFORM_WINDOWS);
-
- /*
- * 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, and only gives a base name if there's at least one
- * character after the last directory separator.
- */
-
- if (strchr(string, '/') == NULL
- && (!onWindows || strchr(string, '\\') == NULL)) {
- /*
- * No directory separator, so just assume we have a file name.
- * This is a bit wrong on Windows where we could have problems
- * with disk name prefixes... but those are much less common in
- * naked form so we just pass through and let the OS figure it out
- * instead.
- */
-
- nameBaseObj = templateObj;
- Tcl_IncrRefCount(nameBaseObj);
- } else if (string[length-1] != '/'
- && (!onWindows || string[length-1] != '\\')) {
- /*
- * If the template has a non-terminal directory separator, split
- * into dirname and tail.
- */
-
- baseDirObj = TclPathPart(interp, templateObj, TCL_PATH_DIRNAME);
- nameBaseObj = TclPathPart(interp, templateObj, TCL_PATH_TAIL);
- } else {
- /*
- * Otherwise, there must be a terminal directory separator, so
- * just the directory is given.
- */
-
- baseDirObj = templateObj;
- Tcl_IncrRefCount(baseDirObj);
- }
-
+ if (objStrings != NULL) {
/*
- * Only allow creation of temporary directories in the native
- * filesystem since they are frequently used for integration with
- * external tools or system libraries.
+ * We don't need this object that was passed to us any more.
*/
- if (baseDirObj != NULL && Tcl_FSGetFileSystemForPath(baseDirObj)
- != &tclNativeFilesystem) {
- TclDecrRefCount(baseDirObj);
- baseDirObj = NULL;
- }
- }
-
- /*
- * Convert empty parts of the template into unspecified parts.
- */
-
- if (baseDirObj && !TclGetString(baseDirObj)[0]) {
- TclDecrRefCount(baseDirObj);
- baseDirObj = NULL;
- }
- if (nameBaseObj && !TclGetString(nameBaseObj)[0]) {
- TclDecrRefCount(nameBaseObj);
- nameBaseObj = NULL;
- }
-
- /*
- * Create and open the temporary file.
- */
-
- makeTemporary:
- dirNameObj = TclpCreateTemporaryDirectory(baseDirObj, nameBaseObj);
-
- /*
- * If we created pieces of template, get rid of them now.
- */
-
- if (baseDirObj) {
- TclDecrRefCount(baseDirObj);
- }
- if (nameBaseObj) {
- TclDecrRefCount(nameBaseObj);
- }
-
- /*
- * Deal with results.
- */
-
- if (dirNameObj == NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't create temporary directory: %s",
- Tcl_PosixError(interp)));
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, dirNameObj);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclFileHomeCmd --
- *
- * This function is invoked to process the "file home" Tcl command.
- * See the user documentation for details on what it does.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclFileHomeCmd(
- TCL_UNUSED(void *),
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Tcl_Obj *homeDirObj;
-
- if (objc != 1 && objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "?user?");
- return TCL_ERROR;
- }
- homeDirObj = TclGetHomeDirObj(interp, objc == 1 ? NULL : TclGetString(objv[1]));
- if (homeDirObj == NULL) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, homeDirObj);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclFileTildeExpandCmd --
- *
- * This function is invoked to process the "file tildeexpand" Tcl command.
- * See the user documentation for details on what it does.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclFileTildeExpandCmd(
- TCL_UNUSED(void *),
- Tcl_Interp *interp,
- int objc,
- Tcl_Obj *const objv[])
-{
- Tcl_Obj *expandedPathObj;
-
- if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "path");
- return TCL_ERROR;
- }
- expandedPathObj = TclResolveTildePath(interp, objv[1]);
- if (expandedPathObj == NULL) {
- return TCL_ERROR;
+ Tcl_DecrRefCount(objStrings);
}
- Tcl_SetObjResult(interp, expandedPathObj);
- return TCL_OK;
+ return result;
}
/*
generated by cgit v0.12 at 2025-12-20 08:00:57 (GMT)