00001 # Copyright (C) 1997-2004 The CDG Team <cdg@nats.informatik.uni-hamburg.de> 00002 # 00003 # This file is free software; as a special exception the author gives 00004 # unlimited permission to copy and/or distribute it, with or without 00005 # modifications, as long as this notice is preserved. 00006 # 00007 # This program is distributed in the hope that it will be useful, but 00008 # WITHOUT ANY WARRANTY, to the extent permitted by law; without even the 00009 # implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. 00010 00011 ## ---------------------------------------------------------------------------- 00012 ## \file error.tcl 00013 ## Overwrite the tcl error suite to deactivated the CdgBusy dialog 00014 ## in case of an error. 00015 ## 00016 ## \author Michael Daum (see also AUTHORS and THANKS for more) 00017 ## 00018 ## $Id: error.tcl,v 1.7 2004/02/25 14:40:41 micha Exp $ 00019 ## ---------------------------------------------------------------------------- 00020 00021 00022 ## global flags used in catch(), error() and bgerror() 00023 set _errorFlag 0 00024 00025 ## global flags used in catch(), error() and bgerror() 00026 set _catchFlag 0 00027 00028 ## \comment 00029 ## force the autoload of the original bgerror function before we overwrite it 00030 if {[auto_load bgerror]} { 00031 rename bgerror _bgerror 00032 } 00033 rename catch _catch 00034 rename error _error 00035 ## \endcomment 00036 00037 00038 ## ---------------------------------------------------------------------------- 00039 ## overwrite the system bgerror command. 00040 ## This function simply flags the error in the global variable \c _errorFlag = 1 00041 ## when it is encountered, deactivates a CdgBusy dialog and the delegates the 00042 ## rest of the call to the origninal bgerror having been renamed to \c _bgerror. 00043 proc bgerror {args} {;## \type TclList 00044 global _errorFlag 00045 00046 set _errorFlag 1 00047 .cdgmain busy abort 00048 eval _bgerror $args 00049 } 00050 00051 ## ---------------------------------------------------------------------------- 00052 ## overwrite the system cache command. 00053 ## This function basically sets the global variable \c catchFlag = 1 before it 00054 ## then calls the system cache command (which was renamed to \c catch). After 00055 ## having done that it sets \c catchFlag = 0 again. So we track the part of 00056 ## call that is being catched, the effect of which is that we want to deactivate 00057 ## the CdgBusy dialog only once in error(). 00058 proc catch {script {varName ""}} {;## \type TclCommand, TclString 00059 global _catchFlag 00060 if {$varName != ""} { 00061 upvar $varName var 00062 } else { 00063 set var "" 00064 } 00065 set _catchFlag 1 00066 set result 0 00067 set result [uplevel _catch [list $script] $varName] 00068 set _catchFlag 0 00069 00070 return $result 00071 } 00072 00073 00074 ## ---------------------------------------------------------------------------- 00075 ## overwrite the system error command. 00076 ## This flag safely deactivates the CdgBusy dialog, i.e. when the \c _catchFlag is not 00077 ## set. If so it also flags the error having taken place in \c _errorFlag = 1. 00078 proc error {message {info ""} {code ""}} {; ## \type TclString, TclString, TclCommand 00079 global _errorFlag errorInfo _catchFlag 00080 00081 if {$_catchFlag == 1} { 00082 return -code error $message 00083 } 00084 00085 set _errorFlag 1 00086 .cdgmain busy abort 00087 ::cmd::Puts "ERROR: $message" 00088 00089 return -code error $message 00090 } 00091 00092