[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.1
----
As 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.
[LES] 2022-11-01 How do I replace my Tk's error dialog? Is there some file I can edit? Is that possible at all, please, pretty please?
----
!!!!!!
%| [Category Development] | [Category Widget] |%
!!!!!!