# tkerror.tcl
#
# tkerror for WebTk
#
# This is another example for you to look at.
# Again, it'll take some work before you can use it directly.
#

set WebTk(errorurl) http://redsonja.sunlabs.com/research/tcl/webtk/autoerror.cgi
#
# tkerror --
#	This is the handler for background errors that arise
#	from commands bound to keystrokes and menus.  A
#	toplevel message widget is used to display $errorInfo

proc tkerror { msg } {
    global errorInfo
    global maintainer

    set font fixed
    set base ".errorInfo"
    set title "Error Info"
    if [info exists errorInfo] {
	set savedErrorInfo $errorInfo
    } else {
	set savedErrorInfo {no errorInfo}
    }
    # Create a toplevel to contain the error trace back
    if [catch {
	# Choose a unique name
	for {set x 1} {$x<10} {set x [expr $x+1]} {
	    if {! [winfo exists $base-$x]} {
		break
	    }
	}
	set title $title-$x
	set name $base-$x

	toplevel $name -bd 2
	wm title $name $title
	wm group $name .
	wm minsize $name 20 5
    
	frame $name.buttons
	pack $name.buttons -side top -fill x
    
	button $name.buttons.quit -text "Dismiss" -command [list destroy $name]
	pack append $name.buttons $name.buttons.quit {left}
	if [info exists maintainer] {
	    button $name.buttons.mailto -text "POST to $maintainer" \
		-command [list MailError $name $errorInfo]
	    pack append $name.buttons $name.buttons.mailto {right}
	}
	global widgetText TextType

	message $name.ex -font $font -aspect 1000 -text \
"Please type a few words of explanation before
pressing the POST button, or just Dismiss me."
	pack $name.ex -side top -fill x
	text $name.user -font $font -width 60 -bd 2 -relief raised
	$name.user configure -height 5
	$name.user insert end "What happened: "
	$name.user tag add sel 1.0 1.14
	focus $name.user
	pack $name.user -side top -fill both -expand true
	$name.user mark set hlimit 1.0
	set widgetText($name.user,extend) 0
	set widgetText($name.user,geo) {}
	set TextType($name.user) text

	frame $name.msg
	pack $name.msg -side top -fill both -expand true

	text $name.msg.t -font $font -width 60 -bd 2 -relief raised \
		-setgrid true -yscrollcommand [list $name.msg.sy set]
	scrollbar $name.msg.sy -orient vertical -command [list $name.msg.t yview]
	set numLines [llength [split $errorInfo \n]]
	if {$numLines > 20} {
	    set numLines 20
	}
	$name.msg.t configure -height $numLines
	$name.msg.t insert end $errorInfo
	pack $name.msg.sy -side right -fill y
	pack $name.msg.t -side left -fill both -expand true
	set widgetText($name.msg.t,extend) 0
	set widgetText($name.msg.t,geo) {}
	set TextType($name.msg.t) text

	catch {tkwait visibility $name}

    }] {
	Stderr "tkrror: $msg"
	Stderr "*** TCL Trace ***"
	Stderr $savedErrorInfo
   }
}
#proc bgerror [info args tkerror] [info body tkerror]

proc MailError { w errInfo } {
    global maintainer argv argv0 WebTk Register tk_version
    catch {set user $env(USER)}
    catch {set user $env(LOGNAME)}
    catch {set user $Register(user)}
    set system unknown
    catch {set system $Register(system)}
    set serial unregistered
    catch {set serial $Register(serial)}
    set email "unknown@nowhere.com"
    catch {set email $Register(email)}

    set query ""
    append query email=[HMmap_reply $email]
    append query &system=[HMmap_reply $system]
    append query &user=[HMmap_reply $user]
    append query &serial=[HMmap_reply $serial]
    append query &date=[HMmap_reply [clock format [clock seconds] -format %C]]
    append query &Tk=[HMmap_reply $tk_version]
    append query &Tcl=[HMmap_reply [info tclversion]]
    append query &message=[HMmap_reply [$w.user get 1.0 end]]
    append query &error=[HMmap_reply $errInfo]

    upvar #0 $WebTk(errorurl) data
    catch {unset data(html)}
    Http_post $WebTk(errorurl) $query [list ErrorConfirm $WebTk(errorurl)] #

    eval destroy [winfo children $w]
    message $w.msg -text "Report posted" -width 200
    button $w.ok -text OK -command "destroy $w"
    pack $w.msg $w.ok -padx 10 -pady 10
}

proc ErrorConfirm {url} {
    upvar #0 $url data
    catch {DialogHtmlInfo {} $data(html)}
}

proc Stderr {string} {
    catch {puts stderr $string}
}
