From: Vince Darley Date: Thu, 20 Feb 2003 12:12:46 +0000 (+0000) Subject: debugging hook added X-Git-Tag: vfs-1-3~43 X-Git-Url: http://privyetmir.co.uk/gitweb?a=commitdiff_plain;h=45c154849c56e73a2a9891a83d1bd8746cbcf865;p=tclvfs debugging hook added --- diff --git a/ChangeLog b/ChangeLog index 468928c..cd15739 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,23 @@ +2003-02-20 Vince Darley + + * 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 * 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);