static int
DoCopyFile(
Tcl_DString *srcPtr, /* Pathname of file to be copied (native). */
Tcl_DString *dstPtr) /* Pathname of file to copy to (native). */
{
CONST TCHAR *nativeSrc, *nativeDst;
nativeSrc = (TCHAR *) Tcl_DStringValue(srcPtr);
nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr);
/*
* Would throw an exception under NT if one of the arguments is a char
* block device.
*/
__try {
if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
return TCL_OK;
}
} __except (-1) {}
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EBADF) {
Tcl_SetErrno(EACCES);
return TCL_ERROR;
}
if (Tcl_GetErrno() == EACCES) {
DWORD srcAttr, dstAttr;
srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
if (srcAttr != 0xffffffff) {
if (dstAttr == 0xffffffff) {
dstAttr = 0;
}
if ((srcAttr & FILE_ATTRIBUTE_DIRECTORY) ||
(dstAttr & FILE_ATTRIBUTE_DIRECTORY)) {
Tcl_SetErrno(EISDIR);
}
if (dstAttr & FILE_ATTRIBUTE_READONLY) {
(*tclWinProcs->setFileAttributesProc)(nativeDst,
dstAttr & ~FILE_ATTRIBUTE_READONLY);
if ((*tclWinProcs->copyFileProc)(nativeSrc, nativeDst, 0) != FALSE) {
return TCL_OK;
}
/*
* Still can't copy onto dst. Return that error, and
* restore attributes of dst.
*/
TclWinConvertError(GetLastError());
(*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
}
}
}
return TCL_ERROR;
}
void
TclWinConvertWSAError(
unsigned long errCode) /* Win32 error code. */
{
if ((errCode >= WSAEWOULDBLOCK) && (errCode <= WSAEREMOTE)) {
Tcl_SetErrno(wsaErrorTable[errCode - WSAEWOULDBLOCK]);
} else {
Tcl_SetErrno(EINVAL);
}
}
void
TclWinConvertError(
unsigned long errCode) /* Win32 error code. */
{
if (errCode >= tableLen) {
Tcl_SetErrno(EINVAL);
} else {
Tcl_SetErrno(errorTable[errCode]);
}
}
void
TclWinConvertError(
DWORD errCode) /* Win32 error code. */
{
if (errCode >= sizeof(errorTable)/sizeof(errorTable[0])) {
errCode -= WSAEWOULDBLOCK;
if (errCode >= sizeof(wsaErrorTable)/sizeof(wsaErrorTable[0])) {
Tcl_SetErrno(errorTable[1]);
} else {
Tcl_SetErrno(wsaErrorTable[errCode]);
}
} else {
Tcl_SetErrno(errorTable[errCode]);
}
}
static int
ConsoleOutput(
ClientData instanceData, /* Indicates which device to use. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
ChannelData *data = instanceData;
ConsoleInfo *info = data->info;
*errorCode = 0;
Tcl_SetErrno(0);
if (info) {
Tcl_Interp *consoleInterp = info->consoleInterp;
if (consoleInterp && !Tcl_InterpDeleted(consoleInterp)) {
Tcl_Obj *cmd = Tcl_NewStringObj("tk::ConsoleOutput", -1);
if (data->type == TCL_STDERR) {
Tcl_ListObjAppendElement(NULL, cmd,
Tcl_NewStringObj("stderr", -1));
} else {
Tcl_ListObjAppendElement(NULL, cmd,
Tcl_NewStringObj("stdout", -1));
}
Tcl_ListObjAppendElement(NULL, cmd,
Tcl_NewStringObj(buf, toWrite));
Tcl_IncrRefCount(cmd);
Tcl_GlobalEvalObj(consoleInterp, cmd);
Tcl_DecrRefCount(cmd);
}
}
return toWrite;
}
static int
ConsoleOutput(
ClientData instanceData, /* Indicates which device to use. */
const char *buf, /* The data buffer. */
int toWrite, /* How many bytes to write? */
int *errorCode) /* Where to store error code. */
{
ChannelData *data = instanceData;
ConsoleInfo *info = data->info;
*errorCode = 0;
Tcl_SetErrno(0);
if (info) {
Tcl_Interp *consoleInterp = info->consoleInterp;
if (consoleInterp && !Tcl_InterpDeleted(consoleInterp)) {
Tcl_DString ds;
Tcl_Encoding utf8 = Tcl_GetEncoding(NULL, "utf-8");
/*
* Not checking for utf8 == NULL. Did not check for TCL_ERROR
* from Tcl_SetChannelOption() in Tk_InitConsoleChannels() either.
* Assumption is utf-8 Tcl_Encoding is reliably present.
*/
const char *bytes
= Tcl_ExternalToUtfDString(utf8, buf, toWrite, &ds);
int numBytes = Tcl_DStringLength(&ds);
Tcl_Obj *cmd = Tcl_NewStringObj("tk::ConsoleOutput", -1);
Tcl_FreeEncoding(utf8);
if (data->type == TCL_STDERR) {
Tcl_ListObjAppendElement(NULL, cmd,
Tcl_NewStringObj("stderr", -1));
} else {
Tcl_ListObjAppendElement(NULL, cmd,
Tcl_NewStringObj("stdout", -1));
}
Tcl_ListObjAppendElement(NULL, cmd,
Tcl_NewStringObj(bytes, numBytes));
Tcl_DStringFree(&ds);
Tcl_IncrRefCount(cmd);
Tcl_EvalObjEx(consoleInterp, cmd, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmd);
}
}
return toWrite;
}
bool init_surfit_lib(Tcl_Interp * interp) {
char * lib = NULL;
lib = getenv("SURFIT_LIB");
char libsurfit[] = "libsurfit[info sharedlibextension]";
bool libs_loaded = false;
char * surfit;
if (lib) {
surfit = (char *) malloc(strlen(lib)+strlen(libsurfit)+7);
strcpy(surfit, "load ");
strcat(surfit, lib);
strcat(surfit, "/");
strcat(surfit, libsurfit);
libs_loaded = true;
// trying to open libsurfit
Tcl_SetErrno(0);
int res = Tcl_EvalEx(interp, surfit, -1, TCL_EVAL_DIRECT);
if (res != TCL_OK)
libs_loaded = false;
free(surfit);
}
if (!libs_loaded) {
// searching in current directory
surfit = (char *) malloc(strlen(libsurfit)+6);
strcpy(surfit, "load ");
strcat(surfit, libsurfit);
bool local_libs_loaded = true;
int res = Tcl_EvalEx(interp, surfit, -1, TCL_EVAL_DIRECT);
if (res != TCL_OK)
local_libs_loaded = false;
free(surfit);
return local_libs_loaded;
}
return libs_loaded;
};
/*-----------------------------------------------------------------------------
* CloseForError --
*
* Close a file on error. If the file is associated with a channel, close
* it too. The error number will be saved and not lost.
*
* Parameters:
* o interp (I) - Current interpreter.
* o channel (I) - Channel to close if not NULL.
* o fileNum (I) - File number to close if >= 0.
*-----------------------------------------------------------------------------
*/
static void
CloseForError (Tcl_Interp *interp,
Tcl_Channel channel,
int fileNum)
{
int saveErrNo = Tcl_GetErrno ();
/*
* Always close fileNum, even if channel close is done, as it doesn't
* close stdin, stdout or stderr numbers.
*/
if (channel != NULL)
Tcl_UnregisterChannel (interp, channel);
if (fileNum >= 0)
close (fileNum);
Tcl_SetErrno (saveErrNo);
}
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;
}
static int
elTclSignal(ClientData data, Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[])
{
ElTclInterpInfo *iinfo = data;
ElTclSignalContext *ctx;
sigset_t set, oset;
int i, signum;
char *action;
if (objc < 2 || objc > 3) {
Tcl_WrongNumArgs(interp, 1, objv,
"signal ?script|-ignore|-default|-block|-unblock?");
return TCL_ERROR;
}
if (objc == 2 &&
!strcmp(Tcl_GetStringFromObj(objv[1], NULL), "names")) {
/* [signal names] */
Tcl_DString dstring;
Tcl_DStringInit(&dstring);
for(i=0; i<ELTCL_MAXSIG; i++) if (signalNames[i] != NULL) {
Tcl_DStringAppendElement(&dstring, signalNames[i]);
}
Tcl_DStringResult(interp, &dstring);
return TCL_OK;
}
/* objv[1] must be a signal name */
signum = -1;
for(i=0; i<ELTCL_MAXSIG; i++) if (signalNames[i] != NULL)
if (!strcmp(Tcl_GetStringFromObj(objv[1], NULL), signalNames[i])) {
signum = i;
break;
}
if (signum < 0) {
/* or an integer */
if (Tcl_GetIntFromObj(interp, objv[1], &signum) == TCL_ERROR)
return TCL_ERROR;
}
/* prepare the interpreter result so that this command returns the
* previous action for that signal */
ctx = getSignalContext(signum, iinfo);
if (ctx == NULL || ctx->script == ELTCL_SIGDFL) {
Tcl_SetResult(interp, "-default", TCL_STATIC);
} else if (ctx->script == ELTCL_SIGIGN) {
Tcl_SetResult(interp, "-ignore", TCL_STATIC);
} else {
Tcl_SetObjResult(interp, ctx->script);
}
/* if no action given, return current script associated with
* signal */
if (objc == 2) { return TCL_OK; }
/* get the given action */
action = Tcl_GetStringFromObj(objv[2], NULL);
/* check if signal should be reset to default */
if (!strcmp(action, "-default")) {
/* special case of SIGWINCH, which we must keep processing */
#ifdef SIGWINCH
if (signum != SIGWINCH)
#endif
if (signal(signum, SIG_DFL) == (void *)-1) goto error;
if (ctx == NULL) return TCL_OK;
if (ctx->script != ELTCL_SIGDFL && ctx->script != ELTCL_SIGIGN) {
Tcl_DecrRefCount(ctx->script);
Tcl_AsyncDelete(ctx->asyncH);
}
ctx->script = ELTCL_SIGDFL;
return TCL_OK;
}
/* check if signal should be ignored */
if (!strcmp(action, "-ignore")) {
if (ctx == NULL) {
ctx = createSignalContext(signum, iinfo);
if (ctx == NULL) goto error;
}
/* special case of SIGWINCH, which we must keep processing */
#ifdef SIGWINCH
if (signum != SIGWINCH)
#endif
if (signal(signum, SIG_IGN) == (void *)-1) goto error;
if (ctx->script != ELTCL_SIGDFL && ctx->script != ELTCL_SIGIGN) {
Tcl_DecrRefCount(ctx->script);
Tcl_AsyncDelete(ctx->asyncH);
}
ctx->script = ELTCL_SIGIGN;
return TCL_OK;
}
/* check if signal should be (un)blocked */
if (!strcmp(action, "-block") || !strcmp(action, "-unblock")) {
Tcl_DString dstring;
int code;
sigemptyset(&set);
sigemptyset(&oset);
sigaddset(&set, signum);
if (!strcmp(action, "-block"))
code = sigprocmask(SIG_BLOCK, &set, &oset);
else
code = sigprocmask(SIG_UNBLOCK, &set, &oset);
if (code) goto error;
/* return the previous mask */
Tcl_DStringInit(&dstring);
for(i=0; i<ELTCL_MAXSIG; i++) if (signalNames[i] != NULL) {
if (sigismember(&oset, i))
Tcl_DStringAppendElement(&dstring, signalNames[i]);
}
Tcl_DStringResult(interp, &dstring);
return TCL_OK;
}
/* a script was given: create async handler and register signal */
if (ctx == NULL) {
ctx = createSignalContext(signum, iinfo);
if (ctx == NULL) goto error;
}
/* block signal while installing handler */
sigemptyset(&set);
sigaddset(&set, signum);
if (sigprocmask(SIG_BLOCK, &set, &oset)) goto error;
#ifdef SIGWINCH
if (signum != SIGWINCH)
#endif
if (signal(signum, signalHandler) == (void *)-1) {
sigprocmask(SIG_SETMASK, &oset, NULL);
goto error;
}
if (ctx->script != ELTCL_SIGDFL && ctx->script != ELTCL_SIGIGN) {
Tcl_DecrRefCount(ctx->script);
Tcl_AsyncDelete(ctx->asyncH);
}
ctx->script = objv[2];
Tcl_IncrRefCount(ctx->script);
ctx->asyncH = Tcl_AsyncCreate(asyncSignalHandler, ctx);
sigprocmask(SIG_SETMASK, &oset, NULL);
return TCL_OK;
error:
Tcl_SetResult(interp, (char *)Tcl_ErrnoMsg(errno), TCL_VOLATILE);
Tcl_SetErrno(errno);
Tcl_PosixError(interp);
return TCL_ERROR;
}
static int
DoRemoveDirectory(
Tcl_DString *pathPtr, /* Pathname of directory to be removed
* (native). */
int recursive, /* If non-zero, removes directories that
* are nonempty. Otherwise, will only remove
* empty directories. */
Tcl_DString *errorPtr) /* If non-NULL, uninitialized or free
* DString filled with UTF-8 name of file
* causing error. */
{
CONST TCHAR *nativePath;
DWORD attr;
nativePath = (TCHAR *) Tcl_DStringValue(pathPtr);
if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
/*
* Win32s thinks that "" is the same as "." and then reports EACCES
* instead of ENOENT.
*/
if (tclWinProcs->useWide) {
if (((WCHAR *) nativePath)[0] == '\0') {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
} else {
if (((char *) nativePath)[0] == '\0') {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
}
if (Tcl_GetErrno() == EACCES) {
attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
if (attr != 0xffffffff) {
if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
/*
* Windows 95 reports calling RemoveDirectory on a file as an
* EACCES, not an ENOTDIR.
*/
Tcl_SetErrno(ENOTDIR);
goto end;
}
if (attr & FILE_ATTRIBUTE_READONLY) {
attr &= ~FILE_ATTRIBUTE_READONLY;
if ((*tclWinProcs->setFileAttributesProc)(nativePath, attr) == FALSE) {
goto end;
}
if ((*tclWinProcs->removeDirectoryProc)(nativePath) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
(*tclWinProcs->setFileAttributesProc)(nativePath,
attr | FILE_ATTRIBUTE_READONLY);
}
/*
* Windows 95 and Win32s report removing a non-empty directory
* as EACCES, not EEXIST. If the directory is not empty,
* change errno so caller knows what's going on.
*/
if (TclWinGetPlatformId() != VER_PLATFORM_WIN32_NT) {
char *path, *find;
HANDLE handle;
WIN32_FIND_DATAA data;
Tcl_DString buffer;
int len;
path = (char *) nativePath;
Tcl_DStringInit(&buffer);
len = strlen(path);
find = Tcl_DStringAppend(&buffer, path, len);
if ((len > 0) && (find[len - 1] != '\\')) {
Tcl_DStringAppend(&buffer, "\\", 1);
}
find = Tcl_DStringAppend(&buffer, "*.*", 3);
handle = FindFirstFileA(find, &data);
if (handle != INVALID_HANDLE_VALUE) {
while (1) {
if ((strcmp(data.cFileName, ".") != 0)
&& (strcmp(data.cFileName, "..") != 0)) {
/*
* Found something in this directory.
*/
Tcl_SetErrno(EEXIST);
break;
}
if (FindNextFileA(handle, &data) == FALSE) {
break;
}
}
FindClose(handle);
}
Tcl_DStringFree(&buffer);
}
}
}
if (Tcl_GetErrno() == ENOTEMPTY) {
/*
* The caller depends on EEXIST to signify that the directory is
* not empty, not ENOTEMPTY.
*/
Tcl_SetErrno(EEXIST);
}
if ((recursive != 0) && (Tcl_GetErrno() == EEXIST)) {
/*
* The directory is nonempty, but the recursive flag has been
* specified, so we recursively remove all the files in the directory.
*/
return TraverseWinTree(TraversalDelete, pathPtr, NULL, errorPtr);
}
end:
if (errorPtr != NULL) {
Tcl_WinTCharToUtf(nativePath, -1, errorPtr);
}
return TCL_ERROR;
}
static int
DoDeleteFile(
Tcl_DString *pathPtr) /* Pathname of file to be removed (native). */
{
DWORD attr;
CONST TCHAR *nativePath;
nativePath = (TCHAR *) Tcl_DStringValue(pathPtr);
if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
/*
* Win32s thinks that "" is the same as "." and then reports EISDIR
* instead of ENOENT.
*/
if (tclWinProcs->useWide) {
if (((WCHAR *) nativePath)[0] == '\0') {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
} else {
if (((char *) nativePath)[0] == '\0') {
Tcl_SetErrno(ENOENT);
return TCL_ERROR;
}
}
if (Tcl_GetErrno() == EACCES) {
attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
if (attr != 0xffffffff) {
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
/*
* Windows NT reports removing a directory as EACCES instead
* of EISDIR.
*/
Tcl_SetErrno(EISDIR);
} else if (attr & FILE_ATTRIBUTE_READONLY) {
(*tclWinProcs->setFileAttributesProc)(nativePath,
attr & ~FILE_ATTRIBUTE_READONLY);
if ((*tclWinProcs->deleteFileProc)(nativePath) != FALSE) {
return TCL_OK;
}
TclWinConvertError(GetLastError());
(*tclWinProcs->setFileAttributesProc)(nativePath, attr);
}
}
} else if (Tcl_GetErrno() == ENOENT) {
attr = (*tclWinProcs->getFileAttributesProc)(nativePath);
if (attr != 0xffffffff) {
if (attr & FILE_ATTRIBUTE_DIRECTORY) {
/*
* Windows 95 reports removing a directory as ENOENT instead
* of EISDIR.
*/
Tcl_SetErrno(EISDIR);
}
}
} else if (Tcl_GetErrno() == EINVAL) {
/*
* Windows NT reports removing a char device as EINVAL instead of
* EACCES.
*/
Tcl_SetErrno(EACCES);
}
return TCL_ERROR;
}
static int
DoRenameFile(
CONST TCHAR *nativeSrc, /* Pathname of file or dir to be renamed
* (native). */
Tcl_DString *dstPtr) /* New pathname for file or directory
* (native). */
{
const TCHAR *nativeDst;
DWORD srcAttr, dstAttr;
nativeDst = (TCHAR *) Tcl_DStringValue(dstPtr);
/*
* Would throw an exception under NT if one of the arguments is a
* char block device.
*/
__try {
if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
return TCL_OK;
}
} __except (-1) {}
TclWinConvertError(GetLastError());
srcAttr = (*tclWinProcs->getFileAttributesProc)(nativeSrc);
dstAttr = (*tclWinProcs->getFileAttributesProc)(nativeDst);
if (srcAttr == 0xffffffff) {
if ((*tclWinProcs->getFullPathNameProc)(nativeSrc, 0, NULL, NULL) >= MAX_PATH) {
errno = ENAMETOOLONG;
return TCL_ERROR;
}
srcAttr = 0;
}
if (dstAttr == 0xffffffff) {
if ((*tclWinProcs->getFullPathNameProc)(nativeDst, 0, NULL, NULL) >= MAX_PATH) {
errno = ENAMETOOLONG;
return TCL_ERROR;
}
dstAttr = 0;
}
if (errno == EBADF) {
errno = EACCES;
return TCL_ERROR;
}
if ((TclWinGetPlatformId() == VER_PLATFORM_WIN32s) && (errno == EACCES)) {
if ((srcAttr != 0) && (dstAttr != 0)) {
/*
* Win32s reports trying to overwrite an existing file or directory
* as EACCES.
*/
errno = EEXIST;
}
}
if (errno == EACCES) {
decode:
if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
TCHAR *nativeSrcRest, *nativeDstRest;
char **srcArgv, **dstArgv;
int size, srcArgc, dstArgc;
WCHAR nativeSrcPath[MAX_PATH];
WCHAR nativeDstPath[MAX_PATH];
Tcl_DString srcString, dstString;
CONST char *src, *dst;
size = (*tclWinProcs->getFullPathNameProc)(nativeSrc, MAX_PATH,
nativeSrcPath, &nativeSrcRest);
if ((size == 0) || (size > MAX_PATH)) {
return TCL_ERROR;
}
size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH,
nativeDstPath, &nativeDstRest);
if ((size == 0) || (size > MAX_PATH)) {
return TCL_ERROR;
}
(*tclWinProcs->charLowerProc)((TCHAR *) nativeSrcPath);
(*tclWinProcs->charLowerProc)((TCHAR *) nativeDstPath);
src = Tcl_WinTCharToUtf((TCHAR *) nativeSrcPath, -1, &srcString);
dst = Tcl_WinTCharToUtf((TCHAR *) nativeDstPath, -1, &dstString);
if (strncmp(src, dst, Tcl_DStringLength(&srcString)) == 0) {
/*
* Trying to move a directory into itself.
*/
errno = EINVAL;
Tcl_DStringFree(&srcString);
Tcl_DStringFree(&dstString);
return TCL_ERROR;
}
Tcl_SplitPath(src, &srcArgc, &srcArgv);
Tcl_SplitPath(dst, &dstArgc, &dstArgv);
Tcl_DStringFree(&srcString);
Tcl_DStringFree(&dstString);
if (srcArgc == 1) {
/*
* They are trying to move a root directory. Whether
* or not it is across filesystems, this cannot be
* done.
*/
Tcl_SetErrno(EINVAL);
} else if ((srcArgc > 0) && (dstArgc > 0) &&
(strcmp(srcArgv[0], dstArgv[0]) != 0)) {
/*
* If src is a directory and dst filesystem != src
* filesystem, errno should be EXDEV. It is very
* important to get this behavior, so that the caller
* can respond to a cross filesystem rename by
* simulating it with copy and delete. The MoveFile
* system call already handles the case of moving a
* file between filesystems.
*/
Tcl_SetErrno(EXDEV);
}
ckfree((char *) srcArgv);
ckfree((char *) dstArgv);
}
/*
* Other types of access failure is that dst is a read-only
* filesystem, that an open file referred to src or dest, or that
* src or dest specified the current working directory on the
* current filesystem. EACCES is returned for those cases.
*/
} else if (Tcl_GetErrno() == EEXIST) {
/*
* Reports EEXIST any time the target already exists. If it makes
* sense, remove the old file and try renaming again.
*/
if (srcAttr & FILE_ATTRIBUTE_DIRECTORY) {
if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
/*
* Overwrite empty dst directory with src directory. The
* following call will remove an empty directory. If it
* fails, it's because it wasn't empty.
*/
if (DoRemoveDirectory(dstPtr, 0, NULL) == TCL_OK) {
/*
* Now that that empty directory is gone, we can try
* renaming again. If that fails, we'll put this empty
* directory back, for completeness.
*/
if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
return TCL_OK;
}
/*
* Some new error has occurred. Don't know what it
* could be, but report this one.
*/
TclWinConvertError(GetLastError());
(*tclWinProcs->createDirectoryProc)(nativeDst, NULL);
(*tclWinProcs->setFileAttributesProc)(nativeDst, dstAttr);
if (Tcl_GetErrno() == EACCES) {
/*
* Decode the EACCES to a more meaningful error.
*/
goto decode;
}
}
} else { /* (dstAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
Tcl_SetErrno(ENOTDIR);
}
} else { /* (srcAttr & FILE_ATTRIBUTE_DIRECTORY) == 0 */
if (dstAttr & FILE_ATTRIBUTE_DIRECTORY) {
Tcl_SetErrno(EISDIR);
} else {
/*
* Overwrite existing file by:
*
* 1. Rename existing file to temp name.
* 2. Rename old file to new name.
* 3. If success, delete temp file. If failure,
* put temp file back to old name.
*/
TCHAR *nativeRest, *nativeTmp, *nativePrefix;
int result, size;
WCHAR tempBuf[MAX_PATH];
size = (*tclWinProcs->getFullPathNameProc)(nativeDst, MAX_PATH,
tempBuf, &nativeRest);
if ((size == 0) || (size > MAX_PATH) || (nativeRest == NULL)) {
return TCL_ERROR;
}
nativeTmp = (TCHAR *) tempBuf;
((char *) nativeRest)[0] = '\0';
((char *) nativeRest)[1] = '\0'; /* In case it's Unicode. */
result = TCL_ERROR;
nativePrefix = (tclWinProcs->useWide)
? (TCHAR *) L"tclr" : (TCHAR *) "tclr";
if ((*tclWinProcs->getTempFileNameProc)(nativeTmp,
nativePrefix, 0, tempBuf) != 0) {
/*
* Strictly speaking, need the following DeleteFile and
* MoveFile to be joined as an atomic operation so no
* other app comes along in the meantime and creates the
* same temp file.
*/
nativeTmp = (TCHAR *) tempBuf;
(*tclWinProcs->deleteFileProc)(nativeTmp);
if ((*tclWinProcs->moveFileProc)(nativeDst, nativeTmp) != FALSE) {
if ((*tclWinProcs->moveFileProc)(nativeSrc, nativeDst) != FALSE) {
(*tclWinProcs->setFileAttributesProc)(nativeTmp,
FILE_ATTRIBUTE_NORMAL);
(*tclWinProcs->deleteFileProc)(nativeTmp);
return TCL_OK;
} else {
(*tclWinProcs->deleteFileProc)(nativeDst);
(*tclWinProcs->moveFileProc)(nativeTmp, nativeDst);
}
}
/*
* Can't backup dst file or move src file. Return that
* error. Could happen if an open file refers to dst.
*/
TclWinConvertError(GetLastError());
if (Tcl_GetErrno() == EACCES) {
/*
* Decode the EACCES to a more meaningful error.
*/
goto decode;
}
}
return result;
}
}
}
return TCL_ERROR;
}
