This is a study on replacing Tk's error dialog. The goal was to have something that better fits into TclTalk's browsers design. The result is completely developed within TclTalk, for TclTalk, while staying portable (without references to other parts of TclTalk).
# 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| Category Development |
|---|