source: branches/blt4/gui/scripts/bugreport.tcl @ 1897

Last change on this file since 1897 was 1897, checked in by gah, 11 years ago

re-merge with latest trunk changes

File size: 18.8 KB
Line 
1# ----------------------------------------------------------------------
2#  UTILITY: bugreport
3#
4#  This redefines the usual Tcl bgerror command to install a nicer
5#  looking bug handler.
6# ======================================================================
7#  AUTHOR:  Michael McLennan, Purdue University
8#  Copyright (c) 2004-2006  Purdue Research Foundation
9#
10#  See the file "license.terms" for information on usage and
11#  redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12# ======================================================================
13option add *BugReport*Label.font {Helvetica -12} startupFile
14option add *BugReport*banner*foreground white startupFile
15option add *BugReport*banner*background #a9a9a9 startupFile
16option add *BugReport*banner*highlightBackground #a9a9a9 startupFile
17option add *BugReport*banner.title.font {Helvetica -18 bold} startupFile
18option add *BugReport*xmit*wrapLength 3i startupFile
19option add *BugReport*expl.width 50 startupFile
20option add *BugReport*expl.font {Helvetica -12} startupFile
21option add *BugReport*expl.boldFont {Helvetica -12 bold} startupFile
22option add *BugReport*comments.l.font {Helvetica -12 italic} startupFile
23option add *BugReport*comments.info.text.font {Helvetica -12} startupFile
24option add *BugReport*details*font {Courier -12} startupFile
25
26namespace eval Rappture::bugreport {
27    # details from the current trouble report
28    variable details
29
30    # assume that if there's a problem launching a job, we should know it
31    variable reportJobFailures 1
32}
33
34# ----------------------------------------------------------------------
35# USAGE: install
36#
37# Called once in the main program to install this bug reporting
38# facility.  Any unexpected errors after this call will be handled
39# by this mechanism.
40# ----------------------------------------------------------------------
41proc Rappture::bugreport::install {} {
42    proc ::bgerror {err} { ::Rappture::bugreport::activate $err }
43}
44
45# ----------------------------------------------------------------------
46# USAGE: activate <error>
47#
48# Used internally to pop up the bug handler whenver a bug is
49# encountered.  Tells the user that there is a bug and logs the
50# problem, so it can be fixed.
51# ----------------------------------------------------------------------
52proc Rappture::bugreport::activate {err} {
53    global env errorInfo
54    variable details
55
56    if {"@SHOWDETAILS" == $err} {
57        pack propagate .bugreport yes
58        pack forget .bugreport.expl
59        pack forget .bugreport.xmit
60        pack forget .bugreport.done
61        pack forget .bugreport.cntls.show
62        pack .bugreport.cntls -after .bugreport.banner -side bottom -fill x
63        pack .bugreport.details -after .bugreport.banner \
64            -expand yes -fill both -padx 8 -pady 8
65        pack .bugreport.comments -after .bugreport.details \
66            -expand yes -fill both -padx 8 -pady {0 8}
67        return
68    }
69
70    # gather details so we can submit trouble reports later
71    # do this now, before we do anything with "catch" down below
72    # that might mask the errorInfo
73    register $err
74
75    pack propagate .bugreport yes
76    pack forget .bugreport.details
77    pack forget .bugreport.xmit
78    pack forget .bugreport.done
79    pack .bugreport.cntls.show -side right
80    pack .bugreport.cntls -after .bugreport.banner -side bottom -fill x
81    pack .bugreport.expl -after .bugreport.banner \
82        -expand yes -fill both -padx 8 -pady 8
83    pack .bugreport.comments -after .bugreport.expl \
84        -expand yes -fill both -padx 8 -pady {0 8}
85
86    .bugreport.expl configure -state normal
87    .bugreport.expl delete 1.0 end
88
89    set url [Rappture::Tool::resources -huburl]
90    if {"" != $url} {
91        .bugreport.expl insert end "Something went wrong with this tool.  Help us understand what happened by submitting a trouble report, so we can fix the problem.  If you continue having trouble with this tool, please close it and restart."
92        .bugreport.cntls.send configure -state normal
93        focus .bugreport.cntls.send
94    } else {
95        .bugreport.expl insert end "Something went wrong with this tool.  We would ask you to submit a trouble report about the error, but we can't tell what hub it should be submitted to.  If you continue having trouble with this tool, please close it and restart."
96        pack forget .bugreport.comments
97        .bugreport.cntls.send configure -state disabled
98        focus .bugreport.cntls.ok
99    }
100    fixTextHeight .bugreport.expl
101    .bugreport.expl configure -state disabled
102
103    .bugreport.details.info.text configure -state normal
104    .bugreport.details.info.text delete 1.0 end
105    .bugreport.details.info.text insert end "    USER: $details(login)\n"
106    .bugreport.details.info.text insert end "HOSTNAME: $details(hostname)\n"
107    .bugreport.details.info.text insert end "    TOOL: $details(referrer)\n"
108    .bugreport.details.info.text insert end " SESSION: $details(session)\n"
109    .bugreport.details.info.text insert end "CATEGORY: $details(category)\n"
110    .bugreport.details.info.text insert end " SUMMARY: $details(summary)\n"
111    .bugreport.details.info.text insert end "---------\n"
112    .bugreport.details.info.text insert end $details(stackTrace)
113    .bugreport.details.info.text configure -state disabled
114
115    set w [winfo reqwidth .bugreport]
116    set h [winfo reqheight .bugreport]
117    set x [expr {([winfo screenwidth .bugreport]-$w)/2}]
118    if {$x < 0} {set x 0}
119    set y [expr {([winfo screenheight .bugreport]-$h)/2}]
120    if {$y < 0} {set y 0}
121
122    wm geometry .bugreport +$x+$y
123    wm deiconify .bugreport
124    raise .bugreport
125
126    catch {grab set .bugreport}
127    update
128}
129
130# ----------------------------------------------------------------------
131# USAGE: deactivate
132#
133# Used internally to take down the bug handler dialog.
134# ----------------------------------------------------------------------
135proc Rappture::bugreport::deactivate {} {
136    grab release .bugreport
137    wm withdraw .bugreport
138
139    # reset the grab in case it's hosed
140    Rappture::grab::reset
141}
142
143# ----------------------------------------------------------------------
144# USAGE: submit
145#
146# Takes details currently stored in the panel and registers them
147# as a support ticket on the hosting hub site.  Pops up a panel
148# during the process and informs the user of the result.
149# ----------------------------------------------------------------------
150proc Rappture::bugreport::submit {} {
151    set info [.bugreport.details.info.text get 1.0 end]
152
153    pack propagate .bugreport no
154    pack forget .bugreport.details
155    pack forget .bugreport.expl
156    pack forget .bugreport.comments
157    pack forget .bugreport.cntls
158    pack .bugreport.xmit -after .bugreport.banner -padx 8 -pady 8
159    .bugreport.xmit.title configure -text "Sending trouble report to [Rappture::Tool::resources -hubname]..."
160
161    # send off the trouble report...
162    .bugreport.xmit.icon start
163    set status [catch send result]
164    .bugreport.xmit.icon stop
165
166    pack propagate .bugreport yes
167    pack forget .bugreport.xmit
168    pack .bugreport.expl -after .bugreport.banner -padx 8 -pady 8
169    .bugreport.expl configure -state normal
170    .bugreport.expl delete 1.0 end
171
172    # handle the result
173    if {$status != 0} {
174        # add error to the details field, so we can see it with magic clicks
175        .bugreport.details.info.text configure -state normal
176        .bugreport.details.info.text insert 1.0 "Ticket submission failed:\n$result\n-----\n"
177        .bugreport.details.info.text configure -state disabled
178
179        .bugreport.expl insert end "Oops! Ticket submission failed:\n$result\n\nIf you want to report the original problem, you can file your own trouble report by going to the web site and clicking on the \"Help\" or \"Support\" link on the main navigation bar.  If you continue having trouble with this tool, please close it and restart."
180    } elseif {[regexp {Ticket #([0-9]*) +\((.*?)\) +([0-9]+) +times} $result match ticket extra times]} {
181        .bugreport.expl insert end "This problem has been reported as " "" "Ticket #$ticket" bold " in our system." ""
182        if {[string is integer $times] && $times > 1} {
183            .bugreport.expl insert end "  This particular problem has been reported $times times."
184        }
185        .bugreport.expl insert end "\n\nIf you continue having trouble with this tool, please close it and restart.  Thanks for reporting the problem and helping us improve things!"
186    } else {
187        .bugreport.expl insert end "This problem has been reported.  Here is the response from the hub, which may contain information about your ticket:\n" "" $result bold "\n\nIf you continue having trouble with this tool, please close it and restart.  Thanks for reporting the problem and helping us improve things!" ""
188    }
189    fixTextHeight .bugreport.expl
190    .bugreport.expl configure -state disabled
191    pack .bugreport.done -side bottom -padx 8 -pady 8
192    focus .bugreport.done
193}
194
195# ----------------------------------------------------------------------
196# USAGE: register <err>
197#
198# Low-level function used to capture information about a bug report
199# prior to calling "send", which actually sends the ticket.  We usually
200# let the user preview the information and decide whether or not to
201# send the ticket.
202# ----------------------------------------------------------------------
203proc Rappture::bugreport::register {err} {
204    global errorInfo tcl_platform
205    variable details
206
207    #
208    # Figure out exactly what we'll send if the bug report is
209    # submitted, so we can show the user.
210    #
211    set stackTrace "$err\n---------\n$errorInfo"
212    if {![regexp {^([^\n]+)\n} $stackTrace match summary]} {
213        if {[string length $stackTrace] == 0} {
214            set summary "Unexpected error from Rappture"
215        } else {
216            set summary $stackTrace
217        }
218    }
219    if {[string length $summary] > 200} {
220        set summary "[string range $summary 0 200]..."
221    }
222    if {[string match {Problem launching job*} $summary]} {
223        append summary " (in tool \"[Rappture::Tool::resources -appname]\")"
224        set category "Tools"
225    } else {
226        set category "Rappture"
227    }
228
229    # make sure that the stack trace isn't too long
230    set toolong 20000
231    if {[string length $stackTrace] > $toolong} {
232        #
233        # If this came from "Problem launching job", then it will have
234        # a "== RAPPTURE INPUT ==" part somewhere in the middle.  Try
235        # to show the first part, this middle part, and the very last
236        # part, cutting out whatever we have to in the middle.
237        #
238        if {[regexp -indices {\n== RAPPTURE INPUT ==\n} $stackTrace match]} {
239            foreach {smid0 smid1} $match break
240            set quarter [expr {$toolong/4}]
241            set s0 $quarter
242            set smid0 [expr {$smid0-$quarter}]
243            set smid1 [expr {$smid1+$quarter}]
244            set s1 [expr {[string length $stackTrace]-$quarter}]
245
246            if {$smid0 < $s0} {
247                # first part is short -- truncate last part
248                set stackTrace "[string range $stackTrace 0 $smid1]\n...\n[string range $stackTrace [expr {[string length $stackTrace]-($toolong-$smid1)}] end]"
249            } elseif {$smid1 > $s1} {
250                # last part is short -- truncate first part
251                set tailsize [expr {[string length $stackTrace]-$smid0}]
252                set stackTrace "[string range $stackTrace 0 [expr {$toolong-$tailsize}]]\n...\n[string range $stackTrace $smid0 end]"
253            } else {
254                # rappture input line is right about in the middle
255                set stackTrace "[string range $stackTrace 0 $s0]\n...\n[string range $stackTrace $smid0 $smid1]\n...\n[string range $stackTrace $s1 end]"
256            }
257        } else {
258            # no Rappture input -- just show first part and last part
259            set half [expr {$toolong/2}]
260            set stackTrace "[string range $stackTrace 0 $half]\n...\n[string range $stackTrace [expr {[string length $stackTrace]-$half}] end]"
261        }
262    }
263
264    set details(summary) $summary
265    set details(category) $category
266    set details(stackTrace) $stackTrace
267    set details(login) $tcl_platform(user)
268    set details(hostname) [info hostname]
269    set details(session) [Rappture::Tool::resources -session]
270    set details(referrer) "tool \"[Rappture::Tool::resources -appname]\""
271}
272
273# ----------------------------------------------------------------------
274# USAGE: send
275#
276# Low-level function used to send bug reports back to the hub site.
277# Error details gathered by a previous call to "register" are sent
278# along as a support ticket.  Returns a string of the following form,
279# representing details about the new or existing ticket:
280#   Ticket #XX (XXXXXX) XX times
281# ----------------------------------------------------------------------
282proc Rappture::bugreport::send {} {
283    variable details
284
285    package require http
286    package require tls
287    http::register https 443 ::tls::socket
288
289    set report $details(stackTrace)
290    set cmts [string trim [.bugreport.comments.info.text get 1.0 end]]
291    if {[string length $cmts] > 0} {
292        set report "$cmts\n[string repeat = 72]\n$report"
293    }
294
295    set query [http::formatQuery \
296        option com_support \
297        task create \
298        no_html 1 \
299        report $report \
300        login $details(login) \
301        sesstoken $details(session) \
302        hostname $details(hostname) \
303        category $details(category) \
304        summary $details(summary) \
305        referrer $details(referrer) \
306    ]
307   
308    set url [Rappture::Tool::resources -huburl]
309    if {[string index $url end] == "/"} {
310        append url "index.php"
311    } else {
312        append url "/index.php"
313    }
314
315    set token [http::geturl $url -query $query -timeout 60000]
316
317    if {[http::ncode $token] != 200} {
318        error [http::code $token]
319    }
320    upvar #0 $token rval
321    set info $rval(body)
322    http::cleanup $token
323
324    if {[regexp {Ticket #[0-9]* +\(.*?\) +[0-9]+ +times} $info match]} {
325        return $match
326    }
327    error "Report received, but ticket may not have been filed.  Here's the result...\n$info"
328}
329
330# ----------------------------------------------------------------------
331# USAGE: fixTextHeight <widget>
332#
333# Used internally to adjust the height of a text widget so it is just
334# tall enough to show the info within it.
335# ----------------------------------------------------------------------
336proc Rappture::bugreport::fixTextHeight {widget} {
337    #
338    # HACK ALERT!  In Tk8.5, we can count display lines directly.
339    #   But for earlier versions, we have to cook up something
340    #   similar.
341    #
342    if {[catch {$widget count -displaylines 1.0 end} h] == 0 && $h > 0} {
343        $widget configure -height $h
344    } else {
345        for {set h 1} {$h < 15} {incr h} {
346            $widget configure -height $h
347            $widget see 1.0
348            update idletasks
349            if {"" != [$widget bbox end-1char]} {
350                break
351            }
352        }
353    }
354}
355
356# ----------------------------------------------------------------------
357# USAGE: shouldReport jobfailures <boolean>
358# USAGE: shouldReport for ?oops|jobs?
359#
360# Used internally to determine whether or not this system should
361# automatically report errors back to the hosting hub.  Returns 1
362# if the tool should, and 0 otherwise.  The decision is made based
363# on whether this is a current tool in production, whether it is
364# being tested in a workspace, and whether the tool commonly generates
365# problems (by pilot error in its input deck).
366# ----------------------------------------------------------------------
367proc Rappture::bugreport::shouldReport {option value} {
368    global env
369
370    switch -- $option {
371        jobfailures {
372            variable reportJobFailures
373            if {![string is boolean $value]} {
374                error "bad value \"$value\": should be boolean"
375            }
376            set reportJobFailures $value
377        }
378        for {
379            # is it being run within a workspace?
380            set appname [Rappture::Tool::resources -appname]
381            if {[string match {[Ww]orkspace*} $appname]} {
382                return 0
383            }
384
385            # if this is a problem launching a job and the tool
386            # expects this, then don't bother with automatic reports.
387            variable reportJobFailures
388            if {"jobs" == $value && !$reportJobFailures} {
389                return 0
390            }
391
392            # this is a real problem -- report it!
393            return 1
394        }
395        default {
396            error "bad option \"$option\": should be jobfailures or for"
397        }
398    }
399}
400
401# ----------------------------------------------------------------------
402# Build the bug reporting dialog
403# ----------------------------------------------------------------------
404toplevel .bugreport -class BugReport -borderwidth 1 -relief solid
405wm overrideredirect .bugreport 1
406wm withdraw .bugreport
407
408frame .bugreport.banner -background #a9a9a9
409pack .bugreport.banner -side top -fill x
410label .bugreport.banner.icon -image [Rappture::icon alert]
411pack .bugreport.banner.icon -side left -padx 2 -pady 2
412label .bugreport.banner.title -text "Oops! Internal Error"
413pack .bugreport.banner.title -side left -padx {0 8} -pady 2
414
415# add these frustration bindings in case the "Dismiss" button is off screen
416bind .bugreport.banner.icon <Double-ButtonPress-1> \
417    Rappture::bugreport::deactivate
418bind .bugreport.banner.title <Double-ButtonPress-1> \
419    Rappture::bugreport::deactivate
420
421set bg [.bugreport cget -background]
422text .bugreport.expl -borderwidth 0 -highlightthickness 0 -background $bg \
423    -height 3 -wrap word
424.bugreport.expl tag configure bold \
425    -font [option get .bugreport.expl boldFont Font]
426#
427# HACK ALERT!  We have problems with fixTextHeight working correctly
428#   on Windows for Tk8.4 and earlier.  To make it work properly, we
429#   add the binding below.  At some point, we'll ditch 8.4 and we can
430#   use the new "count -displaylines" option in Tk8.5.
431#
432bind .bugreport.expl <Map> {Rappture::bugreport::fixTextHeight %W}
433
434frame .bugreport.comments
435label .bugreport.comments.l -text "What were you doing just before this error?" -anchor w
436pack .bugreport.comments.l -side top -anchor w
437Rappture::Scroller .bugreport.comments.info -xscrollmode none -yscrollmode auto
438text .bugreport.comments.info.text -width 30 -height 3 -wrap word
439.bugreport.comments.info contents .bugreport.comments.info.text
440bind .bugreport.comments.info.text <ButtonPress> {focus %W}
441pack .bugreport.comments.info -expand yes -fill both
442
443frame .bugreport.cntls
444pack .bugreport.cntls -side bottom -fill x
445button .bugreport.cntls.ok -text "Ignore" -command {
446    Rappture::bugreport::deactivate
447}
448pack .bugreport.cntls.ok -side left -padx {4 20} -pady 8
449button .bugreport.cntls.send -text "Send Trouble Report" -command {
450    Rappture::bugreport::submit
451}
452pack .bugreport.cntls.send -side right -padx 4 -pady 8
453
454button .bugreport.cntls.show -text "Show Details..." \
455    -command {Rappture::bugreport::activate @SHOWDETAILS}
456pack .bugreport.cntls.show -side right
457
458
459frame .bugreport.details
460Rappture::Scroller .bugreport.details.info -xscrollmode auto -yscrollmode auto
461text .bugreport.details.info.text -width 50 -height 15 -wrap none
462.bugreport.details.info contents .bugreport.details.info.text
463pack .bugreport.details.info -expand yes -fill both
464
465frame .bugreport.xmit
466Rappture::Animicon .bugreport.xmit.icon -images {
467    circle-ball1 circle-ball2 circle-ball3 circle-ball4
468    circle-ball5 circle-ball6 circle-ball7 circle-ball8
469}
470pack .bugreport.xmit.icon -side left
471label .bugreport.xmit.title -anchor w
472pack .bugreport.xmit.title -side left -expand yes -fill x
473
474button .bugreport.done -text "Done" \
475    -command Rappture::bugreport::deactivate
476
477# this binding keeps the bugreport window on top
478bind BugReportOnTop <ButtonPress> {
479    wm deiconify %W
480    raise %W
481}
482set btags [bindtags .bugreport]
483bindtags .bugreport [linsert $btags 0 BugReportOnTop]
Note: See TracBrowser for help on using the repository browser.