
# My version of the default tk routine.

proc tkerror {err} {
    if [catch {xxx_tkerror $err} res] { puts $res }
}

proc xxx_tkerror {err} {
    global errorInfo user_name env options tk_version
    global error_report can_do_open_operation tdv_default
    global post_update_region_current mesher_is_running
    global batch_mode plot_window
    
    set can_do_open_operation 1
    
    set info $errorInfo
    if !$batch_mode {
        if [catch {busy reset}] { busy 0 }
        catch { if {[info exists plot_window] && [winfo exists $plot_window.progress]} { interrupt finish } }
        catch { tdv_active 1 }
    }
    catch { unset mesher_is_running }
    catch { unset post_update_region_current }
    set errorInfo $info
    
    puts $info
    
    set line1 [lindex [split $errorInfo \n] 0]
    set mess ""
    switch -glob -- $line1 {
	    "*space left on device*" {
	        set mess "You have run out of disk space while writing a file. \
		    Please free up some space and try again."
	    }
	    "*couldn't fork*" {
	        set mess "There are too many processes running on your machine. \
		    Please terminate some of them and try again."
	    }
	"   user_error" {
	        mess "user_error\n" red
	        return
	    }
    }
    mess "$line1"
    if {$mess != "" && !$batch_mode} {
	    set ch [tk_dialog .tkerrorDialog "Error" $mess error 0 "Okay" "More info"]
	    if {$ch == 1} {
	        tkerror_stacktrace $errorInfo
	    }
	    return
    }
      
    if ![info exists tk_version] {
	    puts stderr "Error: $err\n$errorInfo"
	    return
    }
    
    if $batch_mode {
        if [info exists error_report(identifier)] {
	        set mess "\nAn internal error has occurred:\n$info\n"
	        mess "$mess" red
	        return
        }
    }
    
    if [info exists error_report(identifier)] {
	    set mess "An internal error has occurred:\n\n$err\n\nYou can report the error\
		    to the maintainers of this software, skip the error and continue working, or view a stack trace."
	    set ch [tk_dialog .tkerrorDialog "Error" $mess error 0 Report Continue "Stack Trace"]
	    switch $ch {
	        1 return
	        0 {
		    if ![catch {tkerror_report $info 0 ""} res] return
		        puts $res
		        puts $errorInfo
	        }
	    }
    } else {
	    if {![info exists options(expert)] || $options(expert)} {
	        if ![tk_dialog .tkerrorDialog "Error" "Error: $err" error 0 OK "Stack Trace"] return
	    } else {
	        tk_dialog .tkerrorDialog "Error" "Error: $err" error 0 OK
	        return
	    }
    }
    tkerror_stacktrace $info
}

proc tkerror_stacktrace {info {header ""}} {
    set w .tkerrorTrace
    catch {top_destroy $w 1}
    if {$header != ""} {
        top_window $w 0 "$header"
        if {[winfo viewable [winfo toplevel [winfo parent $w]]] } {
            wm transient $w [winfo toplevel [winfo parent $w]]
        }
    } else {
        top_window $w 0 "Stack Trace for Error"
    }
    frame $w.b
    if {$header != ""} {
        global tk_error_status
        set tk_error_status 0
        button $w.b.ok -text OK -command "set tk_error_status 1; top_destroy $w"
    } else {
        button $w.b.ok -text Dismiss -command "top_destroy $w"
        button $w.b.save -text Save -command "tkerror_save $w"
    }
    text $w.text -relief raised -bd 2 -width 40 -height 10 -yscrollcommand "$w.scroll set"
    scrollbar $w.scroll -relief flat -command "$w.text yview"
    if {$header != ""} {
        pack $w.b.ok -side left -padx 3m
        pack $w.b -side bottom -padx 3m -pady 3m -ipadx 2m -ipady 1m
    } else {
        pack $w.b.ok $w.b.save -side left -padx 3m
        pack $w.b -side bottom -padx 3m -pady 3m -ipadx 2m -ipady 1m
    }
    pack $w.scroll -side right -fill y
    pack $w.text -side left -expand yes -fill both
    $w.text insert 0.0 $info
    $w.text mark set insert 0.0
    top_geometry $w +300+300
    top_deiconify $w
    if {$header != ""} {
        focus $w
        wm protocol $w WM_DELETE_WINDOW "set tk_error_status 1"
        grab $w
        tkwait variable tk_error_status
    }
}

proc tkerror_save {w} {
    global whoami compile_date
    
    if [catch {open TCL_ERRORS a} fp] {
	set mess "Error: couldn't write [pwd]/TCL_ERRORS: $fp"
    } else {
	puts $fp "Error at [clock format [clock seconds]] ------------------------"
	if [info exists whoami] {
	    puts $fp "Program: $whoami"
	}
	if [info exists compile_date] {
	    puts $fp "Compiled: $compile_date"
	}
	puts $fp [$w.text get 1.0 end]
	close $fp
	set mess "Message appended to file [pwd]/TCL_ERRORS"
    }
    tk_dialog .tkerrorDialog "Message" $mess "" 0 OK
}

# identifier : what the program is
# maintainer : who the stuff gets sent to

proc tkerror_report {info stuff_sent message_first} {
    global error_report toplevel job_name project_dir compile_date source_dirs is_win
    
    if [info exists project_dir] {
	set job $project_dir
    } elseif [info exists job_name] {
	set job $job_name
    }
    
    set subj "Error in $error_report(identifier) from [cmd_whoami]@[cmd_uname_n]"
    
    if 0 {
	if [info exists toplevel(single)] {
	    set tls $toplevel(single)
	    set toplevel(single) 0
	}
    }
    
    switch $stuff_sent {
	0 { set sent "no data" }
	1 { set sent "only geometric data" }
	2 { set sent "full information" }
    }
    
    set mess "${message_first}To help us continue to improve\
	the reliability of this software,\nwe\
	would like to look at some information about the error that has\njust\
	occured.  In this case, $sent about the current\nmodel will\
	be sent to the developers.  We'd also like to have\nyour email address\
	in case we need to get some additional\ninformation about the\
	problem.  We can't guarantee a specific\ntime it will take us to\
	fix this problem but we will do our best.\nIf you need a response to\
	your question quickly, please contact technical\nsupport.\n\nIf\
	you don't want to report this problem now, please\nselect\
 	\"Don't send report\"\n"
    
    if ![info exists error_report(email)] { set error_report(email) "" }
    if ![info exists error_report(name)] { set error_report(name) "" }
    if ![info exists error_report(proxy)] { set error_report(proxy) "" }
    if ![info exists error_report(proxyport)] { set error_report(proxyport) "" }
    
    if 1 { #!$is_win
      set ret [question_box_mult .error_reporting "Error report" $mess \
		 [list [list "Your name" $error_report(name)] \
		      [list "Your email address" $error_report(email)] \
		      [list "HTTP proxy host (if any)" $error_report(proxy)] \
		      [list "HTTP proxy port" $error_report(proxyport)] \
		      [list "What were you doing when this happened?" "" "" text] \
		      [list "Additional comments" "" "" text]] \
		 [list "Send report" "Save report" "Don't send report"] 1]
    } else {
      set ret [question_box_mult .error_reporting "Error report" $mess \
		 [list [list "Your name" $error_report(name)] \
		      [list "Your email address" $error_report(email)] \
		      [list "What were you doing when this happened?" "" "" text] \
		      [list "Additional comments" "" "" text]] \
		 [list "Send report" "Save report" "Don't send report"] 1]
    
    }
    if 0 {
	if [info exists tls] { set toplevel(single) $tls }
    }
    
    if {$ret == ""} {return 0}

    set error_report(name) [lindex $ret 0]
    set error_report(email) [lindex $ret 1]
    set error_report(proxy) [lindex $ret 2]
    set error_report(proxyport) [lindex $ret 3]
    set error_report(doing_what) [lindex $ret 4]
    set error_report(comments) [lindex $ret 5]
    
    if {($error_report(email) == "") && ([lindex $ret end] > 1)} {
	set error_report(email) [string trim [question "Please enter your email address."]]
	if {$error_report(email) == ""} {
	    user_error "Sorry, can't send a bug report without an email address."
	}
    }
    
    set mess "Program: $error_report(identifier)\n"
    if [info exists compile_date] {
	append mess "Compile date: $compile_date\n"
    }
    if [info exists source_dirs] {
	set d 0
	foreach dir $source_dirs {
	    foreach f [glob -nocomplain $dir/*] {
		set t [file mtime $f]
		if {$t > $d} { set d $t }
	    }
	}
	append mess "Tcl files modified: [clock format $d]\n"
    }
    append mess "Reporter: $error_report(name)\n"
    append mess "Email: $error_report(email)\n"
    append mess "System: [cmd_uname_a]\n"
    append mess "Example name: $job\n"
    append mess "Doing what:\n$error_report(doing_what)\n"
    append mess "Comments: \n$error_report(comments)\n"
    append mess "Description:\n$info"
    
    if {[lindex $ret end] > 1} {
       set res [url_report_error $error_report(host) $error_report(proxy) \
		 $error_report(proxyport) $error_report(user) \
		 $error_report(email) $subj $mess]
    
       if {$res == ""} {
	  catch {mess "Problem report sent.\n"}
          return 2
       } else {
	  catch {mess "Problem report not sent: $res.\n" red }
       }
    }

    # ---- now save the report
    set dir [pwd]
    if ![file writable $dir] {set dir ~}
    for {set i 1} 1 {incr i} {
       set file [file join $dir ICEMErrorReport[format %03d $i]]
       if {![file exists $file]} {break}
    }
    if [catch {open $file w} fp] {
        catch {mess "Error: couldn't write report $file: $fp\n" red}
        return ""
    } else {
       puts $fp $mess
       close $fp 
       catch {mess "Problem report saved in $file.\n"}
       return 1
    }
}
