int
TclFileReadLinkCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *contents;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name");
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) {
return TCL_ERROR;
}
contents = Tcl_FSLink(objv[1], NULL, 0);
if (contents == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read link \"%s\": %s",
TclGetString(objv[1]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
Tcl_SetObjResult(interp, contents);
Tcl_DecrRefCount(contents);
return TCL_OK;
}
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;
}
int
TclFileAttrsCmd(
ClientData clientData, /* Unused */
Tcl_Interp *interp, /* The interpreter for error reporting. */
int objc, /* Number of command line arguments. */
Tcl_Obj *const objv[]) /* The command line objects. */
{
int result;
const char *const *attributeStrings;
const char **attributeStringsAllocated = NULL;
Tcl_Obj *objStrings = NULL;
int numObjStrings = -1;
Tcl_Obj *filePtr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "name ?-option value ...?");
return TCL_ERROR;
}
filePtr = objv[1];
if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) {
return TCL_ERROR;
}
objc -= 2;
objv += 2;
result = TCL_ERROR;
Tcl_SetErrno(0);
/*
* Get the set of attribute names from the filesystem.
*/
attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings);
if (attributeStrings == NULL) {
int index;
Tcl_Obj *objPtr;
if (objStrings == NULL) {
if (Tcl_GetErrno() != 0) {
/*
* There was an error, probably that the filePtr is not
* accepted by any filesystem
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read \"%s\": %s",
TclGetString(filePtr), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
/*
* We own the object now.
*/
Tcl_IncrRefCount(objStrings);
/*
* Use objStrings as a list object.
*/
if (Tcl_ListObjLength(interp, objStrings, &numObjStrings) != TCL_OK) {
goto end;
}
attributeStringsAllocated = (const char **)
TclStackAlloc(interp, (1+numObjStrings) * sizeof(char *));
for (index = 0; index < numObjStrings; index++) {
Tcl_ListObjIndex(interp, objStrings, index, &objPtr);
attributeStringsAllocated[index] = TclGetString(objPtr);
}
attributeStringsAllocated[index] = NULL;
attributeStrings = attributeStringsAllocated;
} else if (objStrings != NULL) {
Tcl_Panic("must not update objPtrRef's variable and return non-NULL");
}
/*
* Process the attributes to produce a list of all of them, the value of a
* particular attribute, or to set one or more attributes (depending on
* the number of arguments).
*/
if (objc == 0) {
/*
* Get all attributes.
*/
int index, res = TCL_OK, nbAtts = 0;
Tcl_Obj *listPtr;
listPtr = Tcl_NewListObj(0, NULL);
for (index = 0; attributeStrings[index] != NULL; index++) {
Tcl_Obj *objPtrAttr;
if (res != TCL_OK) {
/*
* Clear the error from the last iteration.
*/
Tcl_ResetResult(interp);
}
res = Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtrAttr);
if (res == TCL_OK) {
Tcl_Obj *objPtr =
Tcl_NewStringObj(attributeStrings[index], -1);
Tcl_ListObjAppendElement(interp, listPtr, objPtr);
Tcl_ListObjAppendElement(interp, listPtr, objPtrAttr);
nbAtts++;
}
}
if (index > 0 && nbAtts == 0) {
/*
* Error: no valid attributes found.
*/
Tcl_DecrRefCount(listPtr);
goto end;
}
Tcl_SetObjResult(interp, listPtr);
} else if (objc == 1) {
/*
* Get one attribute.
*/
int index;
Tcl_Obj *objPtr = NULL;
if (numObjStrings == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\", there are no file attributes in this"
" filesystem", TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL);
goto end;
}
if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings,
"option", INDEX_TEMP_TABLE, &index) != TCL_OK) {
goto end;
}
if (Tcl_FSFileAttrsGet(interp, index, filePtr,
&objPtr) != TCL_OK) {
goto end;
}
Tcl_SetObjResult(interp, objPtr);
} else {
/*
* Set option/value pairs.
*/
int i, index;
if (numObjStrings == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad option \"%s\", there are no file attributes in this"
" filesystem", TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL);
goto end;
}
for (i = 0; i < objc ; i += 2) {
if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings,
"option", INDEX_TEMP_TABLE, &index) != TCL_OK) {
goto end;
}
if (i + 1 == objc) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"value for \"%s\" missing", TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FATTR",
"NOVALUE", NULL);
goto end;
}
if (Tcl_FSFileAttrsSet(interp, index, filePtr,
objv[i + 1]) != TCL_OK) {
goto end;
}
}
}
result = TCL_OK;
/*
* Free up the array we allocated and drop our reference to any list of
* attribute names issued by the filesystem.
*/
end:
if (attributeStringsAllocated != NULL) {
TclStackFree(interp, (void *) attributeStringsAllocated);
}
if (objStrings != NULL) {
Tcl_DecrRefCount(objStrings);
}
return result;
}
static int
CopyRenameOneFile(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *source, /* Pathname of file to copy. May need to be
* translated. */
Tcl_Obj *target, /* Pathname of file to create/overwrite. May
* need to be translated. */
int copyFlag, /* If non-zero, copy files. Otherwise, rename
* them. */
int force) /* If non-zero, overwrite target file if it
* exists. Otherwise, error if target already
* exists. */
{
int result;
Tcl_Obj *errfile, *errorBuffer;
Tcl_Obj *actualSource=NULL; /* If source is a link, then this is the real
* file/directory. */
Tcl_StatBuf sourceStatBuf, targetStatBuf;
if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
return TCL_ERROR;
}
errfile = NULL;
errorBuffer = NULL;
result = TCL_ERROR;
/*
* We want to copy/rename links and not the files they point to, so we use
* lstat(). If target is a link, we also want to replace the link and not
* the file it points to, so we also use lstat() on the target.
*/
if (Tcl_FSLstat(source, &sourceStatBuf) != 0) {
errfile = source;
goto done;
}
if (Tcl_FSLstat(target, &targetStatBuf) != 0) {
if (errno != ENOENT) {
errfile = target;
goto done;
}
} else {
if (force == 0) {
errno = EEXIST;
errfile = target;
goto done;
}
/*
* Prevent copying or renaming a file onto itself. On Windows since
* 8.5 we do get an inode number, however the unsigned short field is
* insufficient to accept the Win32 API file id so it is truncated to
* 16 bits and we get collisions. See bug #2015723.
*/
#if !defined(_WIN32) && !defined(__CYGWIN__)
if ((sourceStatBuf.st_ino != 0) && (targetStatBuf.st_ino != 0)) {
if ((sourceStatBuf.st_ino == targetStatBuf.st_ino) &&
(sourceStatBuf.st_dev == targetStatBuf.st_dev)) {
result = TCL_OK;
goto done;
}
}
#endif
/*
* Prevent copying/renaming a file onto a directory and vice-versa.
* This is a policy decision based on the fact that existing
* implementations of copy and rename on all platforms also prevent
* this.
*/
if (S_ISDIR(sourceStatBuf.st_mode)
&& !S_ISDIR(targetStatBuf.st_mode)) {
errno = EISDIR;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't overwrite file \"%s\" with directory \"%s\"",
TclGetString(target), TclGetString(source)));
goto done;
}
if (!S_ISDIR(sourceStatBuf.st_mode)
&& S_ISDIR(targetStatBuf.st_mode)) {
errno = EISDIR;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't overwrite directory \"%s\" with file \"%s\"",
TclGetString(target), TclGetString(source)));
goto done;
}
/*
* The destination exists, but appears to be ok to over-write, and
* -force is given. We now try to adjust permissions to ensure the
* operation succeeds. If we can't adjust permissions, we'll let the
* actual copy/rename return an error later.
*/
{
Tcl_Obj *perm;
int index;
TclNewLiteralStringObj(perm, "u+w");
Tcl_IncrRefCount(perm);
if (TclFSFileAttrIndex(target, "-permissions", &index) == TCL_OK) {
Tcl_FSFileAttrsSet(NULL, index, target, perm);
}
Tcl_DecrRefCount(perm);
}
}
if (copyFlag == 0) {
result = Tcl_FSRenameFile(source, target);
if (result == TCL_OK) {
goto done;
}
if (errno == EINVAL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error renaming \"%s\" to \"%s\": trying to rename a"
" volume or move a directory into itself",
TclGetString(source), TclGetString(target)));
goto done;
} else if (errno != EXDEV) {
errfile = target;
goto done;
}
/*
* The rename failed because the move was across file systems. Fall
* through to copy file and then remove original. Note that the
* low-level Tcl_FSRenameFileProc in the filesystem is allowed to
* implement cross-filesystem moves itself, if it desires.
*/
}
actualSource = source;
Tcl_IncrRefCount(actualSource);
/*
* Activate the following block to copy files instead of links. However
* Tcl's semantics currently say we should copy links, so any such change
* should be the subject of careful study on the consequences.
*
* Perhaps there could be an optional flag to 'file copy' to dictate which
* approach to use, with the default being _not_ to have this block
* active.
*/
#if 0
#ifdef S_ISLNK
if (copyFlag && S_ISLNK(sourceStatBuf.st_mode)) {
/*
* We want to copy files not links. Therefore we must follow the link.
* There are two purposes to this 'stat' call here. First we want to
* know if the linked-file/dir actually exists, and second, in the
* block of code which follows, some 20 lines down, we want to check
* if the thing is a file or directory.
*/
if (Tcl_FSStat(source, &sourceStatBuf) != 0) {
/*
* Actual file doesn't exist.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error copying \"%s\": the target of this link doesn't"
" exist", TclGetString(source)));
goto done;
} else {
int counter = 0;
while (1) {
Tcl_Obj *path = Tcl_FSLink(actualSource, NULL, 0);
if (path == NULL) {
break;
}
/*
* Now we want to check if this is a relative path, and if so,
* to make it absolute.
*/
if (Tcl_FSGetPathType(path) == TCL_PATH_RELATIVE) {
Tcl_Obj *abs = Tcl_FSJoinToPath(actualSource, 1, &path);
if (abs == NULL) {
break;
}
Tcl_IncrRefCount(abs);
Tcl_DecrRefCount(path);
path = abs;
}
Tcl_DecrRefCount(actualSource);
actualSource = path;
counter++;
/*
* Arbitrary limit of 20 links to follow.
*/
if (counter > 20) {
/*
* Too many links.
*/
Tcl_SetErrno(EMLINK);
errfile = source;
goto done;
}
}
/* Now 'actualSource' is the correct file */
}
}
#endif /* S_ISLNK */
#endif
if (S_ISDIR(sourceStatBuf.st_mode)) {
result = Tcl_FSCopyDirectory(actualSource, target, &errorBuffer);
if (result != TCL_OK) {
if (errno == EXDEV) {
/*
* The copy failed because we're trying to do a
* cross-filesystem copy. We do this through our Tcl library.
*/
Tcl_Obj *copyCommand, *cmdObj, *opObj;
TclNewObj(copyCommand);
TclNewLiteralStringObj(cmdObj, "::tcl::CopyDirectory");
Tcl_ListObjAppendElement(interp, copyCommand, cmdObj);
if (copyFlag) {
TclNewLiteralStringObj(opObj, "copying");
} else {
TclNewLiteralStringObj(opObj, "renaming");
}
Tcl_ListObjAppendElement(interp, copyCommand, opObj);
Tcl_ListObjAppendElement(interp, copyCommand, source);
Tcl_ListObjAppendElement(interp, copyCommand, target);
Tcl_IncrRefCount(copyCommand);
result = Tcl_EvalObjEx(interp, copyCommand,
TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
Tcl_DecrRefCount(copyCommand);
if (result != TCL_OK) {
/*
* There was an error in the Tcl-level copy. We will pass
* on the Tcl error message and can ensure this by setting
* errfile to NULL
*/
errfile = NULL;
}
} else {
errfile = errorBuffer;
if (Tcl_FSEqualPaths(errfile, source)) {
errfile = source;
} else if (Tcl_FSEqualPaths(errfile, target)) {
errfile = target;
}
}
}
} else {
result = Tcl_FSCopyFile(actualSource, target);
if ((result != TCL_OK) && (errno == EXDEV)) {
result = TclCrossFilesystemCopy(interp, source, target);
}
if (result != TCL_OK) {
/*
* We could examine 'errno' to double-check if the problem was
* with the target, but we checked the source above, so it should
* be quite clear
*/
errfile = target;
}
/*
* We now need to reset the result, because the above call,
* may have left set it. (Ideally we would prefer not to pass
* an interpreter in above, but the channel IO code used by
* TclCrossFilesystemCopy currently requires one)
*/
Tcl_ResetResult(interp);
}
if ((copyFlag == 0) && (result == TCL_OK)) {
if (S_ISDIR(sourceStatBuf.st_mode)) {
result = Tcl_FSRemoveDirectory(source, 1, &errorBuffer);
if (result != TCL_OK) {
errfile = errorBuffer;
if (Tcl_FSEqualPaths(errfile, source) == 0) {
errfile = source;
}
}
} else {
result = Tcl_FSDeleteFile(source);
if (result != TCL_OK) {
errfile = source;
}
}
if (result != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf("can't unlink \"%s\": %s",
TclGetString(errfile), Tcl_PosixError(interp)));
errfile = NULL;
}
}
done:
if (errfile != NULL) {
Tcl_Obj *errorMsg = Tcl_ObjPrintf("error %s \"%s\"",
(copyFlag ? "copying" : "renaming"), TclGetString(source));
if (errfile != source) {
Tcl_AppendPrintfToObj(errorMsg, " to \"%s\"",
TclGetString(target));
if (errfile != target) {
Tcl_AppendPrintfToObj(errorMsg, ": \"%s\"",
TclGetString(errfile));
}
}
Tcl_AppendPrintfToObj(errorMsg, ": %s", Tcl_PosixError(interp));
Tcl_SetObjResult(interp, errorMsg);
}
if (errorBuffer != NULL) {
Tcl_DecrRefCount(errorBuffer);
}
if (actualSource != NULL) {
Tcl_DecrRefCount(actualSource);
}
return result;
}
int
TclFileDeleteCmd(
ClientData clientData, /* Unused */
Tcl_Interp *interp, /* Used for error reporting */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
{
int i, force, result;
Tcl_Obj *errfile;
Tcl_Obj *errorBuffer = NULL;
i = FileForceOption(interp, objc - 1, objv + 1, &force);
if (i < 0) {
return TCL_ERROR;
}
errfile = NULL;
result = TCL_OK;
for (i++ ; i < objc; i++) {
Tcl_StatBuf statBuf;
errfile = objv[i];
if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
/*
* Call lstat() to get info so can delete symbolic link itself.
*/
if (Tcl_FSLstat(objv[i], &statBuf) != 0) {
/*
* Trying to delete a file that does not exist is not considered
* an error, just a no-op
*/
if (errno != ENOENT) {
result = TCL_ERROR;
}
} else if (S_ISDIR(statBuf.st_mode)) {
/*
* We own a reference count on errorBuffer, if it was set as a
* result of this call.
*/
result = Tcl_FSRemoveDirectory(objv[i], force, &errorBuffer);
if (result != TCL_OK) {
if ((force == 0) && (errno == EEXIST)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error deleting \"%s\": directory not empty",
TclGetString(objv[i])));
Tcl_PosixError(interp);
goto done;
}
/*
* If possible, use the untranslated name for the file.
*/
errfile = errorBuffer;
/*
* FS supposed to check between translated objv and errfile.
*/
if (Tcl_FSEqualPaths(objv[i], errfile)) {
errfile = objv[i];
}
}
} else {
result = Tcl_FSDeleteFile(objv[i]);
}
if (result != TCL_OK) {
result = TCL_ERROR;
/*
* It is important that we break on error, otherwise we might end
* up owning reference counts on numerous errorBuffers.
*/
break;
}
}
if (result != TCL_OK) {
if (errfile == NULL) {
/*
* We try to accomodate poor error results from our Tcl_FS calls.
*/
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error deleting unknown file: %s",
Tcl_PosixError(interp)));
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error deleting \"%s\": %s",
TclGetString(errfile), Tcl_PosixError(interp)));
}
}
done:
if (errorBuffer != NULL) {
Tcl_DecrRefCount(errorBuffer);
}
return result;
}
int
TclFileMakeDirsCmd(
ClientData clientData, /* Unused */
Tcl_Interp *interp, /* Used for error reporting. */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */
{
Tcl_Obj *errfile = NULL;
int result, i, j, pobjc;
Tcl_Obj *split = NULL;
Tcl_Obj *target = NULL;
Tcl_StatBuf statBuf;
result = TCL_OK;
for (i = 1; i < objc; i++) {
if (Tcl_FSConvertToPathType(interp, objv[i]) != TCL_OK) {
result = TCL_ERROR;
break;
}
split = Tcl_FSSplitPath(objv[i], &pobjc);
Tcl_IncrRefCount(split);
if (pobjc == 0) {
errno = ENOENT;
errfile = objv[i];
break;
}
for (j = 0; j < pobjc; j++) {
target = Tcl_FSJoinPath(split, j + 1);
Tcl_IncrRefCount(target);
/*
* Call Tcl_FSStat() so that if target is a symlink that points to
* a directory we will create subdirectories in that directory.
*/
if (Tcl_FSStat(target, &statBuf) == 0) {
if (!S_ISDIR(statBuf.st_mode)) {
errno = EEXIST;
errfile = target;
goto done;
}
} else if (errno != ENOENT) {
/*
* If Tcl_FSStat() failed and the error is anything other than
* non-existence of the target, throw the error.
*/
errfile = target;
goto done;
} else if (Tcl_FSCreateDirectory(target) != TCL_OK) {
/*
* Create might have failed because of being in a race
* condition with another process trying to create the same
* subdirectory.
*/
if (errno != EEXIST) {
errfile = target;
goto done;
} else if ((Tcl_FSStat(target, &statBuf) == 0)
&& S_ISDIR(statBuf.st_mode)) {
/*
* It is a directory that wasn't there before, so keep
* going without error.
*/
Tcl_ResetResult(interp);
} else {
errfile = target;
goto done;
}
}
/*
* Forget about this sub-path.
*/
Tcl_DecrRefCount(target);
target = NULL;
}
Tcl_DecrRefCount(split);
split = NULL;
}
done:
if (errfile != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create directory \"%s\": %s",
TclGetString(errfile), Tcl_PosixError(interp)));
result = TCL_ERROR;
}
if (split != NULL) {
Tcl_DecrRefCount(split);
}
if (target != NULL) {
Tcl_DecrRefCount(target);
}
return result;
}
int
TclFileLinkCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[])
{
Tcl_Obj *contents;
int index;
if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "?-linktype? linkname ?target?");
return TCL_ERROR;
}
/*
* Index of the 'source' argument.
*/
if (objc == 4) {
index = 2;
} else {
index = 1;
}
if (objc > 2) {
int linkAction;
if (objc == 4) {
/*
* We have a '-linktype' argument.
*/
static const char *const linkTypes[] = {
"-symbolic", "-hard", NULL
};
if (Tcl_GetIndexFromObj(interp, objv[1], linkTypes, "option", 0,
&linkAction) != TCL_OK) {
return TCL_ERROR;
}
if (linkAction == 0) {
linkAction = TCL_CREATE_SYMBOLIC_LINK;
} else {
linkAction = TCL_CREATE_HARD_LINK;
}
} else {
linkAction = TCL_CREATE_SYMBOLIC_LINK | TCL_CREATE_HARD_LINK;
}
if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
return TCL_ERROR;
}
/*
* Create link from source to target.
*/
contents = Tcl_FSLink(objv[index], objv[index+1], linkAction);
if (contents == NULL) {
/*
* We handle three common error cases specially, and for all other
* errors, we use the standard posix error message.
*/
if (errno == EEXIST) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not create new link \"%s\": that path already"
" exists", TclGetString(objv[index])));
Tcl_PosixError(interp);
} else if (errno == ENOENT) {
/*
* There are two cases here: either the target doesn't exist,
* or the directory of the src doesn't exist.
*/
int access;
Tcl_Obj *dirPtr = TclPathPart(interp, objv[index],
TCL_PATH_DIRNAME);
if (dirPtr == NULL) {
return TCL_ERROR;
}
access = Tcl_FSAccess(dirPtr, F_OK);
Tcl_DecrRefCount(dirPtr);
if (access != 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not create new link \"%s\": no such file"
" or directory", TclGetString(objv[index])));
Tcl_PosixError(interp);
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not create new link \"%s\": target \"%s\" "
"doesn't exist", TclGetString(objv[index]),
TclGetString(objv[index+1])));
errno = ENOENT;
Tcl_PosixError(interp);
}
} else {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not create new link \"%s\" pointing to \"%s\": %s",
TclGetString(objv[index]),
TclGetString(objv[index+1]), Tcl_PosixError(interp)));
}
return TCL_ERROR;
}
} else {
if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) {
return TCL_ERROR;
}
/*
* Read link
*/
contents = Tcl_FSLink(objv[index], NULL, 0);
if (contents == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"could not read link \"%s\": %s",
TclGetString(objv[index]), Tcl_PosixError(interp)));
return TCL_ERROR;
}
}
Tcl_SetObjResult(interp, contents);
if (objc == 2) {
/*
* If we are reading a link, we need to free this result refCount. If
* we are creating a link, this will just be objv[index+1], and so we
* don't own it.
*/
Tcl_DecrRefCount(contents);
}
return TCL_OK;
}
static int
FileCopyRename(
Tcl_Interp *interp, /* Used for error reporting. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[], /* Argument strings passed to Tcl_FileCmd. */
int copyFlag) /* If non-zero, copy source(s). Otherwise,
* rename them. */
{
int i, result, force;
Tcl_StatBuf statBuf;
Tcl_Obj *target;
i = FileForceOption(interp, objc - 1, objv + 1, &force);
if (i < 0) {
return TCL_ERROR;
}
i++;
if ((objc - i) < 2) {
Tcl_WrongNumArgs(interp, 1, objv,
"?-option value ...? source ?source ...? target");
return TCL_ERROR;
}
/*
* If target doesn't exist or isn't a directory, try the copy/rename. More
* than 2 arguments is only valid if the target is an existing directory.
*/
target = objv[objc - 1];
if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) {
return TCL_ERROR;
}
result = TCL_OK;
/*
* Call Tcl_FSStat() so that if target is a symlink that points to a
* directory we will put the sources in that directory instead of
* overwriting the symlink.
*/
if ((Tcl_FSStat(target, &statBuf) != 0) || !S_ISDIR(statBuf.st_mode)) {
if ((objc - i) > 2) {
errno = ENOTDIR;
Tcl_PosixError(interp);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"error %s: target \"%s\" is not a directory",
(copyFlag?"copying":"renaming"), TclGetString(target)));
result = TCL_ERROR;
} else {
/*
* Even though already have target == translated(objv[i+1]), pass
* the original argument down, so if there's an error, the error
* message will reflect the original arguments.
*/
result = CopyRenameOneFile(interp, objv[i], objv[i + 1], copyFlag,
force);
}
return result;
}
/*
* Move each source file into target directory. Extract the basename from
* each source, and append it to the end of the target path.
*/
for ( ; i<objc-1 ; i++) {
Tcl_Obj *jargv[2];
Tcl_Obj *source, *newFileName;
source = FileBasename(interp, objv[i]);
if (source == NULL) {
result = TCL_ERROR;
break;
}
jargv[0] = objv[objc - 1];
jargv[1] = source;
newFileName = TclJoinPath(2, jargv);
Tcl_IncrRefCount(newFileName);
result = CopyRenameOneFile(interp, objv[i], newFileName, copyFlag,
force);
Tcl_DecrRefCount(newFileName);
Tcl_DecrRefCount(source);
if (result == TCL_ERROR) {
break;
}
}
return result;
}
static void
InitVars(Tcl_Interp *interp)
{
const char *machine, *os, *vers, *user;
char *tmp, *p;
char buffer[20];
Tcl_DString arch;
Tcl_Obj *path;
TnmInitPath(interp);
Tcl_SetVar2(interp, "tnm", "version", TNM_VERSION, TCL_GLOBAL_ONLY);
Tcl_SetVar2(interp, "tnm", "url", TNM_URL, TCL_GLOBAL_ONLY);
/*
* Get the startup time of the Tnm extension.
*/
if (! tnmStartTime.sec && ! tnmStartTime.usec) {
Tcl_GetTime(&tnmStartTime);
}
sprintf(buffer, "%ld", tnmStartTime.sec);
Tcl_SetVar2(interp, "tnm", "start", buffer, TCL_GLOBAL_ONLY);
/*
* Check if the current version of the Tnm extension is still valid
* or if it has expired. Note, this is only useful in distribution
* demos or test versions. This check should be turned off on all
* stable and final releases.
*/
#ifdef TNM_EXPIRE_TIME
if (tnmStartTime.sec > TNM_EXPIRE_TIME) {
Tcl_Panic("Tnm Tcl extension expired. Please upgrade to a newer version.");
}
sprintf(buffer, "%ld", TNM_EXPIRE_TIME);
Tcl_SetVar2(interp, "tnm", "expire", buffer, TCL_GLOBAL_ONLY);
#endif
/*
* Set the host name. We are only interested in the name and not
* in a fully qualified domain name. This makes the result
* predictable and thus portable.
*/
tmp = ckstrdup(Tcl_GetHostName());
p = strchr(tmp, '.');
if (p) *p = '\0';
Tcl_SetVar2(interp, "tnm", "host", tmp, TCL_GLOBAL_ONLY);
ckfree(tmp);
/*
* Get the user name. We try a sequence of different environment
* variables in the hope to find something which works on all
* systems.
*/
user = getenv("USER");
if (user == NULL) {
user = getenv("USERNAME");
if (user == NULL) {
user = getenv("LOGNAME");
if (user == NULL) {
user = "******";
}
}
}
Tcl_SetVar2(interp, "tnm", "user", user, TCL_GLOBAL_ONLY);
/*
* Search for a directory which allows to hold temporary files.
* Save the directory name in the tnm(tmp) variable.
*/
tmp = getenv("TEMP");
if (! tmp) {
tmp = getenv("TMP");
if (! tmp) {
tmp = "/tmp";
if (access(tmp, W_OK) != 0) {
tmp = ".";
}
}
}
for (p = tmp; *p; p++) {
if (*p == '\\') {
*p = '/';
}
}
Tcl_SetVar2(interp, "tnm", "tmp", tmp, TCL_GLOBAL_ONLY);
/*
* Determine the architecture string which is used to store
* machine dependend files in the Tnm cache area.
*/
machine = Tcl_GetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY);
os = Tcl_GetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
vers = Tcl_GetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY);
Tcl_DStringInit(&arch);
if (machine && os && vers) {
Tcl_DStringAppend(&arch, machine, -1);
Tcl_DStringAppend(&arch, "-", 1);
Tcl_DStringAppend(&arch, os, -1);
Tcl_DStringAppend(&arch, "-", 1);
Tcl_DStringAppend(&arch, vers, -1);
} else {
Tcl_DStringAppend(&arch, "unknown-os", -1);
}
/*
* Initialize the tnm(cache) variable which points to a directory
* where we can cache shared data between different instantiations
* of the Tnm extension. We usually locate the cache in the users
* home directory. However, if this fails (because the user does
* not have a home), we locate the cache in the tmp file area.
*/
path = Tcl_NewObj();
Tcl_AppendStringsToObj(path, "~/.tnm", TNM_VERSION, NULL);
if (Tcl_FSConvertToPathType(interp, path) == TCL_ERROR) {
Tcl_SetStringObj(path, tmp, -1);
Tcl_AppendStringsToObj(path, "/tnm", TNM_VERSION, NULL);
}
if (Tcl_FSConvertToPathType(interp, path) == TCL_OK) {
(void) TnmMkDir(interp, path);
}
Tcl_SetVar2(interp, "tnm", "cache",
Tcl_GetStringFromObj(path, NULL), TCL_GLOBAL_ONLY);
Tcl_DecrRefCount(path);
/*
* Remove all white spaces and slashes from the architecture string
* because these characters are a potential source of problems and
* I really do not like white spaces in a directory name.
*/
{
char *d = Tcl_DStringValue(&arch);
char *s = Tcl_DStringValue(&arch);
while (*s) {
*d = *s;
if ((!isspace((int) *s)) && (*s != '/')) d++;
s++;
}
*d = '\0';
}
Tcl_SetVar2(interp, "tnm", "arch",
Tcl_DStringValue(&arch), TCL_GLOBAL_ONLY);
Tcl_DStringFree(&arch);
}
