source: trunk/gui/scripts/bugreport.tcl @ 2035

Last change on this file since 2035 was 1943, checked in by gah, 14 years ago

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