# error.tcl
#
# tkerror for exmh
#
# This is another example for you to look at.
# Again, it'll take some work before you can use it directly.
#
# Copyright (c) 1993 Xerox Corporation.
# Use and copying of this software and preparation of derivative works based
# upon this software are permitted. Any distribution of this software or
# derivative works must comply with all applicable United States export
# control laws. This software is made available AS IS, and Xerox Corporation
# makes no warranty about the software, its performance or its conformity to
# any specification.

#
# 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 "Mail 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 Mail to 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

	tkwait visibility $name

    }] {
	puts stderr "tkrror: $msg"
	puts stderr "*** TCL Trace ***"
	puts stderr $savedErrorInfo
   }
}

proc MailError { w errInfo } {
    global maintainer argv
    if [catch {open /tmp/exmhErrorMsg w} out] {
	Exmh_Status "Cannot open /tmp/exmhErrorMsg" purple
	return
    }
    if [catch {
	global env tk_version
	puts $out "To: maintainer"
	puts $out "Subject: error"
	puts $out ""
	puts $out "Date [exec date]"
	if [info exists env(USER)] {
	    puts $out "$env(USER) got an error"
	}
	puts $out "$argv"
	puts $out "TK version $tk_version"
	puts $out "TCL version [info tclversion]"
	catch {exec uname -a} uname
	puts $out "$uname"
	puts $out ""
	puts $out [$w.user get 1.0 end]
	puts $out ""
	puts $out $errInfo
	close $out
    } msg] {
	puts stderr "/tmp/exmhErrorMsg $msg"
	return
    }
    if [catch {
	exec /usr/lib/sendmail $maintainer < /tmp/exmhErrorMsg
    } msg] {
	puts stderr "sendmail error: $msg"
	return
    } else {
	puts stderr "Mailed report to $maintainer"
	destroy $w
    }
}

