debugging hook added

diff --git a/ChangeLog b/ChangeLog
index 468928c3299399cbf699212d83ad7362fac392e7..cd1573966336ee7c98f8c0fb8802fe86c92b9e79 100644 (file)
--- 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 43e0ca52c2cc99d8a621a5bef2b59e9a52f73954..ede5523b537a7f930b12c1d8a872c21ceed7f442 100644 (file)
--- 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;
 }
-
+\f
+/* 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);
+    }
+}
+\f
 /* 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;
-}\f
+}
+\f
 /*
  *----------------------------------------------------------------------
  *
@@ -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);