source: branches/1.7/gui/scripts/bugreport.tcl @ 6685

Last change on this file since 6685 was 6685, checked in by clarksm, 6 years ago

Upgrade TLS protocol with merge from trunk 6684

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