tb This is a study on replacing Tk's error dialog. The goal was to have something that better fits into TclTalk's browser's design. The result is developed completely within TclTalk, for TclTalk. It works by wrapping the $::errorInfo variable's content and then presenting a browser for the procedures of the calling stack. When you select a procedure's name, then you get the proc's source in a text widget with a hilighted calling line.
# Package tcltalkerrdlg
#
namespace eval ::tcltalk::errdlg {}
variable ::tcltalk::errdlg::CALLERS
variable ::tcltalk::errdlg::ERR
variable ::tcltalk::errdlg::INFO
variable ::tcltalk::errdlg::button
proc ::tcltalk::errdlg::collectCallers {args} {
# 2008-07-31|15:30:35|tb
# Wrap up $::errorInfo to get a list of
# procedure names and line numbers
set lines [split "$::tcltalk::errdlg::INFO" \n]
set pr ""
set nr ""
set result {}
foreach ln $lines {
set l [string trim $ln]
if {[string range $l 1 4]=="proc"} {
regsub -all {\(} $l "" l
regsub -all {\)} $l "" l
regsub -all {\"} $l "" l
set pr [lindex [split $l " "] 1]
set nr [lindex [split $l " "] 3]
lappend result $pr
lappend result $nr
}
}
return $result
}
proc ::tcltalk::errdlg::initializeNamespace {args} {
# 2008-07-31|15:10:54|tb
# Namespaces with dynamic variable content are
# generally better initialized somewhere, also
# other special initialization can be scripted
# here, as TclTalk adds a call to this script
# at the end of a packages source file.
set ::tcltalk::errdlg::CALLERS {}
set ::tcltalk::errdlg::ERR ""
set ::tcltalk::errdlg::INFO ""
set ::tcltalk::errdlg::button 0
if {[info proc ::bgerror*] == "::bgerror"} {
rename ::bgerror ::_bgerror
}
proc ::bgerror {err} {
::tcltalk::errdlg::open $err
}
}
proc ::tcltalk::errdlg::open {args} {
# 2008-07-31|17:41:24|tb
# This shows the error dialog, to be used as a replacement
# for the source version of ::bgerror
variable button
set ::tcltalk::errdlg::INFO $::errorInfo
set ::tcltalk::errdlg::ERR "Error: [lindex [split $::tcltalk::errdlg::INFO \n] 0]"
set ::tcltalk::errdlg::CALLERS [::tcltalk::errdlg::collectCallers]
catch {destroy .errDlg}
set w [toplevel .errDlg]
wm title $w "Application Error"
set lblfont {Times 12 bold italic}
pack [frame $w.labels -relief flat -borderwidth 2] -side top -fill x
pack [canvas $w.labels.bitmap -width 32 -height 32 -highlightthickness 0] -side left
$w.labels.bitmap create oval 0 0 31 31 -fill red -outline black
$w.labels.bitmap create line 9 9 23 23 -fill white -width 4
$w.labels.bitmap create line 9 23 23 9 -fill white -width 4
pack [label $w.labels.info -wrap 600 -textvar ::tcltalk::errdlg::ERR -font $lblfont -foreground red -anchor w] -side left -fill x
pack [frame $w.procs -relief flat -borderwidth 2] -side top -fill x
pack [listbox $w.procs.lb -yscroll [list $w.procs.sb set] -height 4] -side left -fill both -expand true
bind $w.procs.lb <<ListboxSelect>> [list ::tcltalk::errdlg::selectProcedure $w.procs.lb]
pack [scrollbar $w.procs.sb -orient vertical -command [list $w.procs.lb yview]] -side right -fill y
pack [frame $w.code -relief flat -borderwidth 2] -side top -fill both -expand true
pack [::workspace $w.code.ws -width 64 -height 16 -yscroll [list $w.code.sb set]] -side left -fill both -expand true
pack [scrollbar $w.code.sb -orient vertical -command [list $w.code.ws yview]] -side right -fill y
pack [frame $w.buttons -relief flat -borderwidth 2] -side bottom -fill x
set buttons [list ok Ok dismiss "Skip Messages"]
set i 0
foreach {name caption} $buttons {
pack [button $w.buttons.$name -text $caption -default normal -command [namespace code [list set button $i]]] -side left
incr i
}
$w.buttons.ok configure -default active
foreach {p l} $::tcltalk::errdlg::CALLERS {
$w.procs.lb insert end $p
}
::tk::SetFocusGrab $w $w.buttons.ok
vwait [namespace which -variable button]
set copy $button; # Save a copy...
::tk::RestoreFocusGrab $w $w.buttons.ok destroy
if {$copy == 1} {
return -code break
}
}
proc ::tcltalk::errdlg::selectProcedure {w} {
# 2008-07-31|15:53:44|tb
# This event handler is bound to <<ListboxSelect>>
# on the error dialogs listbox.
if {[winfo exists $w]} {
set ndx [lindex [$w curselection] 0]
if {"$ndx" != ""} {
set p [$w get $ndx]
set t [winfo toplevel $w]
set ws $t.code.ws
$ws delete 1.0 end
$ws insert end [::tcltalk::errdlg::see $p]
$ws.t edit modified 0
array set linenos $::tcltalk::errdlg::CALLERS
$ws.t see $linenos($p).0
$ws.t tag add errln $linenos($p).0 "$linenos($p).0 lineend"
$ws.t tag configure errln -background [lindex [$w configure -selectbackground] end]
$ws.t tag configure errln -foreground white
}
}
}
proc ::tcltalk::errdlg::see {cmd} {
# 2008-08-01|00:00:40|tb
set result "proc $cmd \{[info args $cmd]\} \{"
append result [info body $cmd]
append result "\}"
return [string map {\t " "} $result]
}
# Initialization
::tcltalk::errdlg::initializeNamespace
package provide tcltalkerrdlg 0.1As one can see, it hasn't been optimized much. It was developed using a top down approach, starting with a procedure which later became ::tcltalk::errdlg::open, in a 2,5h session but resulted IMO in a fairly structurized package, ready to be shared among TclTalk images.
tb To make this package more portable (i.e. load it into wish), find the line...
pack [::workspace $w.code.ws -width 64 -height 16 -yscroll [list $w.code.sb set]] -side left -fill both -expand true
...in ::tcltalk::errdlg::open and replace "::workspace" with "text".
Also use this version of selectProcedure:
proc ::tcltalk::errdlg::selectProcedure {w} {
# 2008-07-31|15:53:44|tb
# This event handler is bound to <<ListboxSelect>>
# on the error dialogs listbox.
if {[winfo exists $w]} {
set ndx [lindex [$w curselection] 0]
if {"$ndx" != ""} {
set p [$w get $ndx]
set t [winfo toplevel $w]
set ws $t.code.ws
$ws delete 1.0 end
$ws insert end [::tcltalk::errdlg::see $p]
$ws edit modified 0
array set linenos $::tcltalk::errdlg::CALLERS
$ws see $linenos($p).0
$ws tag add errln $linenos($p).0 "$linenos($p).0 lineend"
$ws tag configure errln -background [lindex [$w configure -selectbackground] end]
$ws tag configure errln -foreground white
}
}
}rahulj nice code show more info and controlable errors but how to unset ::bgerror?
tb How about...
rename ::bgerror ::_bgerror_ rename ::_bgerror ::bgerror
That should restore the original error handler.