#
# Copyright (c) 1993 Eric Schenk.
# All rights reserved.
#
# Permission is hereby granted, without written agreement and without
# license or royalty fees, to use, copy, modify, and distribute this
# software and its documentation for any purpose, provided that the
# above copyright notice and the following two paragraphs appear in
# all copies of this software.
# 
# IN NO EVENT SHALL ERIC SCHENK BE LIABLE TO ANY PARTY FOR
# DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
# OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF ERIC
# SCHENK HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
#
# ERIC SCHENK SPECIFICALLY DISCLAIMS ANY WARRANTIES,
# INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
# AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
# ON AN "AS IS" BASIS, AND ERIC SCHENK HAS NO OBLIGATION TO
# PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
#
# tkerror for stkwm.
#
# Loosly based upon tkerror for exmh.
# Portions of this code Copyright (c) 1993 Xerox Coporation, original
# copyright message below.
#
# 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

set tkwm_priv(in_tkerror) 0

proc tkerror { msg } {
    global errorInfo
    global tkwm
    global tkwm_priv

    if !$tkwm_priv(in_tkerror) {
	set tkwm_priv(in_tkerror) 1
	set font fixed
	set base ".errorInfo"
	set title "Tkwm Internal Error Info"
	if [info exists errorInfo] {
	    set savedErrorInfo $errorInfo
	} else {
	    set savedErrorInfo {no errorInfo}
	}
	set savedErrorInfo "Error Message:\n$msg\nTCL Stack Trace:\n$errorInfo"

	# Create a toplevel to contain the error trace back
	if [catch {
	    # Choose a unique name by testing for the associated error variable
	    # Use the string ".errorInfo-N" as the name of the toplevel
	    # and as the name of a variable holding the current errorInfo
	    for {set x 1} {"1"} {set x [expr $x+1]} {
		if {! [winfo exists $base-$x]} {
		    break
		}
	    }
	    set title $title-$x
	    set name $base-$x

	    set wx [expr ($x%20)*10]
	    set inside [create_iwindow $name tkwmError TkwmError]
	    upvar "#0" $name data
	    wm iconname $name "Stack Trace"
	    wm minsize $name 1 1
	    wm iconbitmap $name error

	    wm title $name $title
	    $data(decoration) config -title [wm title $name]
	
	    frame $inside.buttons
	    pack $inside.buttons -side top -fill x -expand 0

	    button $inside.buttons.quit -text "Dismiss" -command [list destroy $name]
	    pack $inside.buttons.quit -side left
	    if [info exists tkwm(maintainer)] {
		button $inside.buttons.mailto -text "Mail to $tkwm(maintainer)" -command [list TkwmMailError $name $inside $savedErrorInfo]
		pack $inside.buttons.mailto -side right
	    }

	    text $inside.user -font $font -width 80 -bd 2 -relief raised
	    $inside.user configure -height 3
	    $inside.user insert end "User notes (PLEASE tell me something about\n"
	    $inside.user insert end "what you where doing when this error happened): "
	    pack $inside.user -side top -expand 1 -fill both

	    text $inside.msg -font $font -width 80 -bd 2 -relief raised
	    set numLines [llength [split $savedErrorInfo \n]]
	    if {$numLines > 20} {
		set numLines 20
	    }
	    $inside.msg configure -height $numLines
	    $inside.msg insert end $savedErrorInfo
	    pack $inside.msg -side top -expand 1 -fill both
	    update idletasks
	    set x [expr [winfo screenwidth $name]/2 - [winfo reqwidth $name]/2 \
		    - [winfo vrootx [winfo parent $name]]]
	    set y [expr [winfo screenheight $name]/2 - [winfo reqheight $name]/2 \
		    - [winfo vrooty [winfo parent $name]]]
	    wm geom $name +$x+$y
	    imap_request $name 0
	} oops] {
	    set msg [concat $msg "($name: " $oops ")" ]
	    puts stderr $savedErrorInfo
	}
	set tkwm_priv(in_tkerror) 0
    } else {
	set msg [concat "Recursive call to tkerror. Error message:\n" $msg]
	puts stderr $msg
    }
}

proc TkwmMailError { w inside errInfo } {
    global tkwm
    if [catch {open /tmp/tkwmErrorMsg w} out] {
	puts "Cannot open /tmp/tkwmErrorMsg"
	return
    }
    if [catch {
	global env
	puts $out "Date [exec date]"
	if [info exists env(USER)] {
	    puts $out "User $env(USER) got an error"
	}
	puts $out "Tkwm version $tkwm(version)"
	puts $out ""
	puts $out [$inside.user get 1.0 end]
	puts $out ""
	puts $out $errInfo
	close $out
    } msg] {
	puts "Write failed on /tmp/tkwmErrorMsg"
	return
    }
    if [catch {
	exec mail -s "tkwm error" $tkwm(maintainer) </tmp/tkwmErrorMsg
	exec rm /tmp/tkwmErrorMsg
    } msg] {
	return
    } else {
	destroy $w
    }
}