Replacing Tk's error dialog

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.