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