From 45c154849c56e73a2a9891a83d1bd8746cbcf865 Mon Sep 17 00:00:00 2001
From: Vince Darley <vincentdarley@sourceforge.net>
Date: Thu, 20 Feb 2003 12:12:46 +0000
Subject: [PATCH] debugging hook added
---
ChangeLog | 20 ++++++++++
generic/vfs.c | 102 +++++++++++++++++++++++++++++++++++++++++++++++---
2 files changed, 116 insertions(+), 6 deletions(-)
diff --git a/ChangeLog b/ChangeLog
index 468928c..cd15739 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,23 @@
+2003-02-20 Vince Darley <vincentdarley@sourceforge.net>
+
+ * generic/vfs.c: added new debugging feature
+ 'vfs::filesystem internalerror ?script?' which can be used
+ to specify a script to evaluate when any tclvfs implementation
+ throws an error. Once implementation of all .tcl's is complete,
+ they should only return TCL_OK or a posix error code. Any other
+ code will signal an error which can be caught using this new
+ proc. If the script is not set, the behaviour of this extension
+ is unchanged.
+
+ Note that this has only been applied to those VFS api's which
+ are not currently able to pass an error message at the Tcl level.
+ Some (open, matchindirectory, fileattributes with get/set) are
+ already able to pass their errors up, so these cases are *not*
+ passed to this handler.
+
+ * library/mk4vfs.tcl: made one change to support the above
+ feature.
+
2003-02-19 Vince Darley <vincentdarley@sourceforge.net>
* library/mk4vfs.tcl: added 'commit' attribute
diff --git a/generic/vfs.c b/generic/vfs.c
index 43e0ca5..ede5523 100644
--- a/generic/vfs.c
+++ b/generic/vfs.c
@@ -63,6 +63,20 @@ static Tcl_Obj *vfsVolumes = NULL;
*/
TCL_DECLARE_MUTEX(vfsVolumesMutex)
+/*
+ * Stores a script to evaluate when an internal error is detected in
+ * a tclvfs implementation. This is most useful for debugging.
+ *
+ * When it is not NULL we keep a refCount on it.
+ */
+static Tcl_Obj *internalErrorScript = NULL;
+
+/*
+ * Declare a mutex for thread-safety of modification of the
+ * internal error script.
+ */
+TCL_DECLARE_MUTEX(internalErrorMutex)
+
/*
* struct Vfs_InterpCmd --
*
@@ -680,11 +694,14 @@ VfsFilesystemObjCmd(dummy, interp, objc, objv)
int index;
static CONST char *optionStrings[] = {
- "info", "mount", "unmount", "fullynormalize", "posixerror",
+ "info", "internalerror", "mount", "unmount",
+ "fullynormalize", "posixerror",
NULL
};
+
enum options {
- VFS_INFO, VFS_MOUNT, VFS_UNMOUNT, VFS_NORMALIZE, VFS_POSIXERROR
+ VFS_INFO, VFS_INTERNAL_ERROR, VFS_MOUNT, VFS_UNMOUNT,
+ VFS_NORMALIZE, VFS_POSIXERROR
};
if (objc < 2) {
@@ -697,6 +714,39 @@ VfsFilesystemObjCmd(dummy, interp, objc, objv)
}
switch ((enum options) index) {
+ case VFS_INTERNAL_ERROR: {
+ int posixError = -1;
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?script?");
+ return TCL_ERROR;
+ }
+ if (objc == 2) {
+ /* Return the current script */
+ Tcl_MutexLock(&internalErrorMutex);
+ if (internalErrorScript != NULL) {
+ Tcl_SetObjResult(interp, internalErrorScript);
+ }
+ Tcl_MutexUnlock(&internalErrorMutex);
+ } else {
+ /* Set the script */
+ int len;
+ CONST char* str = Tcl_GetStringFromObj(objv[2],&len);
+ Tcl_MutexLock(&internalErrorMutex);
+ if (internalErrorScript != NULL) {
+ Tcl_DecrRefCount(internalErrorScript);
+ }
+ if (len == 0) {
+ /* Clear our script */
+ internalErrorScript = NULL;
+ } else {
+ /* Set it */
+ internalErrorScript = objv[2];
+ Tcl_IncrRefCount(internalErrorScript);
+ }
+ Tcl_MutexUnlock(&internalErrorMutex);
+ }
+ return TCL_OK;
+ }
case VFS_POSIXERROR: {
int posixError = -1;
if (objc != 3) {
@@ -800,7 +850,20 @@ VfsFilesystemObjCmd(dummy, interp, objc, objv)
}
return TCL_OK;
}
-
+
+/* Handle an error thrown by a tcl vfs implementation */
+static void
+VfsInternalError(Tcl_Interp* interp) {
+ if (interp != NULL) {
+ Tcl_MutexLock(&internalErrorMutex);
+ if (internalErrorScript != NULL) {
+ Tcl_EvalObjEx(interp, internalErrorScript,
+ TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
+ }
+ Tcl_MutexUnlock(&internalErrorMutex);
+ }
+}
+
/* Return fully normalized path owned by the caller */
static Tcl_Obj*
VfsFullyNormalizePath(Tcl_Interp *interp, Tcl_Obj *pathPtr) {
@@ -859,7 +922,8 @@ VfsFullyNormalizePath(Tcl_Interp *interp, Tcl_Obj *pathPtr) {
Tcl_IncrRefCount(path);
Tcl_DecrRefCount(pathPtr);
return path;
-}
+}
+
/*
*----------------------------------------------------------------------
*
@@ -1152,10 +1216,14 @@ VfsStat(pathPtr, bufPtr)
}
}
+ if (returnVal != TCL_OK && returnVal != -1) {
+ VfsInternalError(interp);
+ }
+
Tcl_RestoreResult(interp, &savedResult);
Tcl_DecrRefCount(mountCmd);
- if (returnVal != 0) {
+ if (returnVal != TCL_OK && returnVal != -1) {
Tcl_SetErrno(ENOENT);
return -1;
} else {
@@ -1183,6 +1251,9 @@ VfsAccess(pathPtr, mode)
Tcl_SaveResult(interp, &savedResult);
returnVal = Tcl_EvalObjEx(interp, mountCmd,
TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
+ if (returnVal != TCL_OK && returnVal != -1) {
+ VfsInternalError(interp);
+ }
Tcl_RestoreResult(interp, &savedResult);
Tcl_DecrRefCount(mountCmd);
@@ -1340,6 +1411,7 @@ VfsOpenFileChannel(cmdInterp, pathPtr, mode, permissions)
static void
VfsCloseProc(ClientData clientData) {
VfsChannelCleanupInfo * channelRet = (VfsChannelCleanupInfo*) clientData;
+ int returnVal;
Tcl_SavedResult savedResult;
Tcl_Channel chan = channelRet->channel;
Tcl_Interp * interp = channelRet->interp;
@@ -1352,8 +1424,11 @@ VfsCloseProc(ClientData clientData) {
* the Tcl code to use the channel's string-name).
*/
Tcl_RegisterChannel(interp, chan);
- Tcl_EvalObjEx(interp, channelRet->closeCallback,
+ returnVal = Tcl_EvalObjEx(interp, channelRet->closeCallback,
TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
+ if (returnVal != TCL_OK) {
+ VfsInternalError(interp);
+ }
Tcl_DecrRefCount(channelRet->closeCallback);
/*
@@ -1442,6 +1517,9 @@ VfsDeleteFile(
Tcl_SaveResult(interp, &savedResult);
returnVal = Tcl_EvalObjEx(interp, mountCmd,
TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
+ if (returnVal != TCL_OK && returnVal != -1) {
+ VfsInternalError(interp);
+ }
Tcl_RestoreResult(interp, &savedResult);
Tcl_DecrRefCount(mountCmd);
return returnVal;
@@ -1465,6 +1543,9 @@ VfsCreateDirectory(
Tcl_SaveResult(interp, &savedResult);
returnVal = Tcl_EvalObjEx(interp, mountCmd,
TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
+ if (returnVal != TCL_OK && returnVal != -1) {
+ VfsInternalError(interp);
+ }
Tcl_RestoreResult(interp, &savedResult);
Tcl_DecrRefCount(mountCmd);
return returnVal;
@@ -1495,6 +1576,9 @@ VfsRemoveDirectory(
Tcl_SaveResult(interp, &savedResult);
returnVal = Tcl_EvalObjEx(interp, mountCmd,
TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
+ if (returnVal != TCL_OK && returnVal != -1) {
+ VfsInternalError(interp);
+ }
Tcl_RestoreResult(interp, &savedResult);
Tcl_DecrRefCount(mountCmd);
@@ -1529,6 +1613,9 @@ VfsFileAttrStrings(pathPtr, objPtrRef)
/* Now we execute this mount point's callback. */
returnVal = Tcl_EvalObjEx(interp, mountCmd,
TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
+ if (returnVal != TCL_OK && returnVal != -1) {
+ VfsInternalError(interp);
+ }
if (returnVal == TCL_OK) {
*objPtrRef = Tcl_DuplicateObj(Tcl_GetObjResult(interp));
} else {
@@ -1646,6 +1733,9 @@ VfsUtime(pathPtr, tval)
Tcl_SaveResult(interp, &savedResult);
returnVal = Tcl_EvalObjEx(interp, mountCmd,
TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT);
+ if (returnVal != TCL_OK && returnVal != -1) {
+ VfsInternalError(interp);
+ }
Tcl_RestoreResult(interp, &savedResult);
Tcl_DecrRefCount(mountCmd);
--
2.23.0