/*
* 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"
/*
* 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(
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(
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 - 2, objv + 2, &force);
if (i < 0) {
return TCL_ERROR;
}
i += 2;
if ((objc - i) < 2) {
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.
*/
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_AppendResult(interp, "error ",
(copyFlag ? "copying" : "renaming"), ": target \"",
TclGetString(target), "\" is not a directory", 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.
*/
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;
Tcl_Obj *temp;
source = FileBasename(interp, objv[i]);
if (source == NULL) {
result = TCL_ERROR;
break;
}
jargv[0] = objv[objc - 1];
jargv[1] = source;
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) {
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(
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;
int result, i, j, pobjc;
Tcl_Obj *split = NULL;
Tcl_Obj *target = NULL;
Tcl_StatBuf statBuf;
errfile = NULL;
result = TCL_OK;
for (i = 2; 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++) {
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.
*/
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) {
/* 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;
}
/* Already tried, with delete in-between directly after
* creation, so just continue (assume created successful). */
goto nextPart;
}
/* return with error */
errfile = target;
goto done;
}
nextPart:
/*
* Forget about this sub-path.
*/
Tcl_DecrRefCount(target);
target = NULL;
}
Tcl_DecrRefCount(split);
split = NULL;
}
done:
if (errfile != NULL) {
Tcl_AppendResult(interp, "can't create directory \"",
TclGetString(errfile), "\": ", Tcl_PosixError(interp), NULL);
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(
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 - 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 < 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) {
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_AppendResult(interp, "error deleting \"",
TclGetString(objv[i]), "\": directory not empty",
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.
*/
if (Tcl_FSEqualPaths(objv[i], errfile)) {
errfile = objv[i];
}
}
} else {
result = Tcl_FSDeleteFile(objv[i]);
}
if (result != TCL_OK) {
/*
* 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 accomodate poor error results from our Tcl_FS calls.
*/
Tcl_AppendResult(interp, "error deleting unknown file: ",
Tcl_PosixError(interp), NULL);
} else {
Tcl_AppendResult(interp, "error deleting \"",
TclGetString(errfile), "\": ", Tcl_PosixError(interp),
NULL);
}
}
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_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_AppendResult(interp, "can't overwrite directory \"",
TclGetString(target), "\" with file \"",
TclGetString(source), "\"", 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.
*/
{
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_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;
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_AppendResult(interp, "error copying \"", TclGetString(source),
"\": the target of this link doesn't exist", 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.
*/
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) {
if (Tcl_FSEqualPaths(errfile, source) == 0) {
errfile = source;
}
}
} else {
result = Tcl_FSDeleteFile(source);
if (result != TCL_OK) {
errfile = source;
}
}
if (result != TCL_OK) {
Tcl_AppendResult(interp, "can't unlink \"", TclGetString(errfile),
"\": ", Tcl_PosixError(interp), NULL);
errfile = NULL;
}
}
done:
if (errfile != NULL) {
Tcl_AppendResult(interp, "error ", (copyFlag ? "copying" : "renaming"),
" \"", TclGetString(source), NULL);
if (errfile != source) {
Tcl_AppendResult(interp, "\" to \"", TclGetString(target), NULL);
if (errfile != target) {
Tcl_AppendResult(interp, "\": \"", TclGetString(errfile),NULL);
}
}
Tcl_AppendResult(interp, "\": ", Tcl_PosixError(interp), NULL);
}
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;
force = 0;
for (i = 0; i < objc; i++) {
if (TclGetString(objv[i])[0] != '-') {
break;
}
if (strcmp(TclGetString(objv[i]), "-force") == 0) {
force = 1;
} 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;
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(
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 ** attributeStrings;
Tcl_Obj* objStrings = NULL;
int numObjStrings = -1, didAlloc = 0;
Tcl_Obj *filePtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv,
"name ?option? ?value? ?option value ...?");
return TCL_ERROR;
}
filePtr = objv[2];
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
*/
Tcl_AppendResult(interp, "could not read \"",
TclGetString(filePtr), "\": ", Tcl_PosixError(interp),
NULL);
}
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;
}
attributeStrings = (CONST char **) TclStackAlloc(interp,
(1+numObjStrings) * sizeof(char*));
didAlloc = 1;
for (index = 0; index < numObjStrings; index++) {
Tcl_ListObjIndex(interp, objStrings, index, &objPtr);
attributeStrings[index] = TclGetString(objPtr);
}
attributeStrings[index] = NULL;
} else if (objStrings != NULL) {
Tcl_Panic("must not update objPtrRef's variable and return non-NULL");
}
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_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", 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;
}
Tcl_SetObjResult(interp, objPtr);
} else {
/*
* Set option/value pairs.
*/
int i, index;
if (numObjStrings == 0) {
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", 0, &index) != TCL_OK) {
goto end;
}
if (didAlloc) {
TclFreeIntRep(objv[i]);
objv[i]->typePtr = NULL;
}
if (i + 1 == objc) {
Tcl_AppendResult(interp, "value for \"",
TclGetString(objv[i]), "\" missing", NULL);
goto end;
}
if (Tcl_FSFileAttrsSet(interp, index, filePtr,
objv[i + 1]) != TCL_OK) {
goto end;
}
}
}
result = TCL_OK;
end:
if (didAlloc) {
/*
* Free up the array we allocated.
*/
TclStackFree(interp, (void *)attributeStrings);
}
if (objStrings != NULL) {
/*
* We don't need this object that was passed to us any more.
*/
Tcl_DecrRefCount(objStrings);
}
return result;
}
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
* fill-column: 78
* End:
*/
