library/bgerror.tcl

   1 # tkerror.tcl --
   2 #
   3 # This file contains a default version of the tkError procedure.  It
   4 # posts a dialog box with the error message and gives the user a chance
   5 # to see a more detailed stack trace.
   6 #
   7 # Copyright (c) 1992-1994 The Regents of the University of California.
   8 # Copyright (c) 1994-1995 Sun Microsystems, Inc.
   9 # Copyright (c) 1999 Christian Werner
  10 #
  11 # See the file "license.terms" for information on usage and redistribution
  12 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  13
  14 if {[winfo depth .] > 1} {
  15     option add *ckerrorDialog*background red
  16     option add *ErrorTrace*background red
  17 }
  18
  19 # Fake the auto_mkindex procedure for Tcl 7.4 \
  20 proc tkerror err {}
  21
  22 # Fake the auto_mkindex procedure for Tcl 7.5 and above \
  23 proc bgerror err {}
  24
  25 # tkerror --
  26 # This is the default version of tkerror.  It posts a dialog box containing
  27 # the error message and gives the user a chance to ask to see a stack
  28 # trace.
  29 #
  30 # Arguments:
  31 # err -                 The error message.
  32
  33 if {$tcl_version > 7.4} {
  34     set ckPriv(bgErrProc) bgerror
  35 } else {
  36     set ckPriv(bgErrProc) tkerror
  37 }
  38     proc $ckPriv(bgErrProc) err {
  39     global errorInfo
  40     set info $errorInfo
  41     set button [ck_dialog .ckerrorDialog "Error in Tcl Script" \
  42             "Error: $err" Okay Skip Trace]
  43     if {$button == 0} {
  44         return
  45     } elseif {$button == 1} {
  46         return -code break
  47     }
  48     set w .ckerrorTrace
  49     catch {destroy $w}
  50     toplevel $w -class ErrorTrace \
  51         -border { ulcorner hline urcorner vline lrcorner hline llcorner vline }
  52     place $w -relx 0.5 -rely 0.5 -anchor center
  53     label $w.title -text "Stack Trace for Error"
  54     place $w.title -y 0 -relx 0.5 -anchor center -bordermode ignore
  55     button $w.ok -text OK -command "destroy $w"
  56     scrollbar $w.scroll -command "$w.text yview" -takefocus 0
  57     text $w.text -yscrollcommand "$w.scroll set"
  58     frame $w.sep -border hline
  59     pack $w.ok -side bottom -ipadx 1
  60     pack $w.sep -side bottom -fill x
  61     pack $w.scroll -side right -fill y
  62     pack $w.text -side left -expand 1 -fill both
  63     $w.text insert 0.0 $info
  64     $w.text mark set insert 0.0
  65     bind $w.text <Tab> {focus [ck_focusNext %W] ; break}
  66     focus $w.ok
  67     tkwait window $w
  68 }
  69