added support for saving bug reports (for ease of offline submission)
also cleaned up a bunch of little things in the bug report implementation: - the abort had race conditions - formatted the collections a little bit better (hopefully) - broke the implementation up into multiple files - fixed broken interaction with drracket (the drracket frame mixin is now being used properly)
This commit is contained in:
Robby Findler
parent
80f573cc0e
commit
0542d3ca70
|
|
@ -153,12 +153,74 @@
|
|||
menu
|
||||
(get-additional-important-urls))
|
||||
(new menu-item%
|
||||
(label (string-constant bug-report-submit-menu-item))
|
||||
(parent menu)
|
||||
(callback
|
||||
[label (string-constant bug-report-submit-menu-item)]
|
||||
[parent menu]
|
||||
[callback
|
||||
(λ (x y)
|
||||
(help-desk:report-bug))))
|
||||
|
||||
(define saved (saved-bug-report-titles/ids))
|
||||
(cond
|
||||
[(null? saved)
|
||||
(help-desk:report-bug #f #:frame-mixin basics-mixin)]
|
||||
[else
|
||||
(define which #f)
|
||||
(define (done the-one)
|
||||
(set! which the-one)
|
||||
(send dlg show #f))
|
||||
(define dlg (new dialog%
|
||||
[label (string-constant drscheme)]
|
||||
[parent this]))
|
||||
(define btn1 (new button%
|
||||
[parent dlg]
|
||||
[label (string-constant new-bug-report)]
|
||||
[callback (λ (x y) (done #f))]))
|
||||
(new message% [parent dlg] [label (string-constant saved-unsubmitted-bug-reports)])
|
||||
(define btns
|
||||
(cons btn1
|
||||
(for/list ([a-brinfo (in-list saved)])
|
||||
(new button%
|
||||
[parent dlg]
|
||||
[label (brinfo-title a-brinfo)]
|
||||
[callback
|
||||
(λ (x y) (done (brinfo-id a-brinfo)))]))))
|
||||
(define width (apply max (map (λ (x) (let-values ([(w h) (send x get-client-size)]) w))
|
||||
btns)))
|
||||
(for ([x (in-list btns)])
|
||||
(send x min-width width))
|
||||
(send btn1 focus)
|
||||
(send dlg show #t)
|
||||
(help-desk:report-bug which #:frame-mixin basics-mixin)]))])
|
||||
(new menu%
|
||||
[label (string-constant saved-bug-reports-menu-item)]
|
||||
[parent menu]
|
||||
[demand-callback
|
||||
(let ([last-time (gensym)]) ;; a unique thing to guarantee the menu is built the first time
|
||||
(λ (saved-bug-reports-menu)
|
||||
(define this-time (saved-bug-report-titles/ids))
|
||||
(unless (equal? last-time this-time)
|
||||
(set! last-time this-time)
|
||||
(for ([x (in-list (send saved-bug-reports-menu get-items))])
|
||||
(send x delete))
|
||||
(cond
|
||||
[(null? this-time)
|
||||
(send (new menu-item%
|
||||
[parent saved-bug-reports-menu]
|
||||
[label (string-constant no-saved-bug-reports)]
|
||||
[callback void])
|
||||
enable #f)]
|
||||
[else
|
||||
(unless (null? (cdr this-time))
|
||||
(new menu-item%
|
||||
[parent saved-bug-reports-menu]
|
||||
[label (string-constant disacard-all-saved-bug-reports)]
|
||||
[callback (λ (x y) (discard-all-saved-bug-reports))])
|
||||
(new separator-menu-item% [parent saved-bug-reports-menu]))
|
||||
(for ([a-brinfo (in-list this-time)])
|
||||
(new menu-item%
|
||||
[parent saved-bug-reports-menu]
|
||||
[label (brinfo-title a-brinfo)]
|
||||
[callback
|
||||
(λ (x y)
|
||||
(help-desk:report-bug (brinfo-id a-brinfo) #:frame-mixin basics-mixin))]))]))))])
|
||||
(drracket:app:add-language-items-to-help-menu menu))
|
||||
|
||||
(define/override (file-menu:new-string) (string-constant new-menu-item))
|
||||
|
|
|
|||
|
|
@ -89,8 +89,6 @@
|
|||
|
||||
(drracket:modes:add-initial-modes)
|
||||
|
||||
(namespace-set-variable-value! 'help-desk:frame-mixin drracket:frame:basics-mixin)
|
||||
|
||||
(finder:default-filters (list* '("Racket (.rkt)" "*.rkt")
|
||||
'("Racket (.ss)" "*.ss")
|
||||
'("Racket (.scm)" "*.scm")
|
||||
|
|
|
|||
|
|
@ -7,517 +7,248 @@
|
|||
net/url
|
||||
net/uri-codec
|
||||
browser/htmltext
|
||||
setup/dirs
|
||||
"private/buginfo.ss")
|
||||
"private/bug-report-controls.rkt"
|
||||
"private/buginfo.ss"
|
||||
"private/save-bug-report.rkt")
|
||||
|
||||
(provide help-desk:report-bug)
|
||||
(provide help-desk:report-bug
|
||||
(struct-out brinfo)
|
||||
saved-bug-report-titles/ids
|
||||
discard-all-saved-bug-reports)
|
||||
|
||||
(define bug-www-server "bugs.racket-lang.org")
|
||||
(define bug-www-server-port 80)
|
||||
|
||||
;; this one should be defined by help desk.
|
||||
(define frame-mixin
|
||||
(namespace-variable-value 'help-desk:frame-mixin #f (lambda () (lambda (x) x))))
|
||||
|
||||
(preferences:set-default 'drracket:email "" string? #:aliases '(drscheme:email))
|
||||
(preferences:set-default 'drracket:full-name "" string? #:aliases '(drscheme:full-name))
|
||||
|
||||
(define bug-frame%
|
||||
(class (frame-mixin (frame:standard-menus-mixin frame:basic%))
|
||||
(init title)
|
||||
|
||||
;; a bunch of stuff we don't want
|
||||
(define/override (file-menu:between-print-and-close menu) (void))
|
||||
(define/override (edit-menu:between-find-and-preferences menu) (void))
|
||||
(define/override (file-menu:create-open?) #f)
|
||||
(define/override (file-menu:create-open-recent?) #f)
|
||||
(define/override (file-menu:create-new?) #f)
|
||||
(define/override (file-menu:create-save?) #f)
|
||||
(define/override (file-menu:create-revert?) #f)
|
||||
|
||||
(field (ok-to-close? #f))
|
||||
(public set-ok-to-close)
|
||||
(define (set-ok-to-close ok?) (set! ok-to-close? #t))
|
||||
(define/augment (can-close?)
|
||||
(or ok-to-close?
|
||||
(ask-yes-or-no (string-constant cancel-bug-report?)
|
||||
(string-constant are-you-sure-cancel-bug-report?)
|
||||
this)))
|
||||
|
||||
(super-make-object title)))
|
||||
(define open-frames '())
|
||||
|
||||
(define (discard-all-saved-bug-reports)
|
||||
(discard-all-except
|
||||
(λ (id) (ormap (λ (frame) (equal? (send frame get-bug-id) id))
|
||||
open-frames))))
|
||||
|
||||
(define (help-desk:report-bug)
|
||||
(define bug-frame (instantiate bug-frame% () (title (string-constant bug-report-form))))
|
||||
(define (help-desk:report-bug [this-bug-id #f] #:frame-mixin [frame-mixin values])
|
||||
(cond
|
||||
[this-bug-id
|
||||
(let loop ([open-frames open-frames])
|
||||
(cond
|
||||
[(null? open-frames)
|
||||
(report-bug/new-frame this-bug-id frame-mixin)]
|
||||
[else
|
||||
(let ([open-frame (car open-frames)])
|
||||
(if (= (send open-frame get-bug-id) this-bug-id)
|
||||
(send open-frame show #t)
|
||||
(loop (cdr open-frames))))]))]
|
||||
[else
|
||||
(report-bug/new-frame this-bug-id frame-mixin)]))
|
||||
|
||||
(define (report-bug/new-frame this-bug-id frame-mixin)
|
||||
(define bug-frame%
|
||||
(class (frame-mixin (frame:standard-menus-mixin frame:basic%))
|
||||
(init title)
|
||||
(init-field bug-id)
|
||||
(define/public (get-bug-id) (and editing? bug-id))
|
||||
|
||||
(define editing? #t)
|
||||
(define/public (no-longer-editing) (set! editing? #f))
|
||||
(define/augment (on-close)
|
||||
(inner (void) on-close)
|
||||
(set! open-frames (remq this open-frames)))
|
||||
(super-make-object title)
|
||||
(set! open-frames (cons this open-frames))
|
||||
|
||||
;; a bunch of stuff we don't want
|
||||
(define/override (file-menu:between-print-and-close menu) (void))
|
||||
(define/override (edit-menu:between-find-and-preferences menu) (void))
|
||||
(define/override (file-menu:create-open?) #f)
|
||||
(define/override (file-menu:create-open-recent?) #f)
|
||||
(define/override (file-menu:create-new?) #f)
|
||||
(define/override (file-menu:create-save?) #f)
|
||||
(define/override (file-menu:create-revert?) #f)))
|
||||
|
||||
(define init-bug-report (if this-bug-id
|
||||
(lookup-bug-report this-bug-id)
|
||||
(register-new-bug-id)))
|
||||
(define bug-frame (new bug-frame%
|
||||
[bug-id (saved-report-id init-bug-report)]
|
||||
[title (string-constant bug-report-form)]))
|
||||
(define single (new panel:single% (parent (send bug-frame get-area-container))))
|
||||
(define outermost-panel (make-object vertical-panel% single))
|
||||
(define compose-panel (make-object vertical-panel% single))
|
||||
|
||||
(define response-panel (new vertical-panel% (parent single)))
|
||||
(define response-text (new (html-text-mixin text%) (auto-wrap #t)))
|
||||
(define response-ec (new editor-canvas% (parent response-panel) (editor response-text)))
|
||||
(define response-button-panel (new horizontal-panel%
|
||||
(stretchable-height #f)
|
||||
(parent response-panel)
|
||||
(alignment '(right center))))
|
||||
(define cancel-kill-thread #f)
|
||||
(define response-reset (new button%
|
||||
(parent response-button-panel)
|
||||
(enabled #f)
|
||||
(label (string-constant dialog-back))
|
||||
(callback
|
||||
(lambda (x y)
|
||||
(switch-to-compose-view)))))
|
||||
(define response-abort (new button%
|
||||
(parent response-button-panel)
|
||||
(enabled #f)
|
||||
(callback
|
||||
(lambda (x y)
|
||||
(kill-thread cancel-kill-thread)
|
||||
(switch-to-compose-view)))
|
||||
(label (string-constant abort))))
|
||||
(define response-close (new button%
|
||||
(parent response-button-panel)
|
||||
(enabled #f)
|
||||
(callback (lambda (x y) (cleanup-frame)))
|
||||
(label (string-constant close))))
|
||||
(new grow-box-spacer-pane% (parent response-button-panel))
|
||||
(define cancel-kill-cust #f)
|
||||
|
||||
(define top-panel (make-object vertical-panel% outermost-panel))
|
||||
(define-values (compose-view-focus get-query sanity-checking)
|
||||
(add-bug-report-controls compose-panel
|
||||
init-bug-report
|
||||
(λ () (ok))
|
||||
(λ () (cancel))
|
||||
(λ () (close-and-save))))
|
||||
|
||||
(define (switch-to-response-view)
|
||||
(send response-text lock #f)
|
||||
(send response-text erase)
|
||||
(render-html-to-text ; hack to get nice text in
|
||||
(open-input-string
|
||||
" <br><br><br><br><br><div align=\"center\"><h2><b>Submitting bug report...</b></h2></div>")
|
||||
response-text #t #f)
|
||||
(send response-text lock #t)
|
||||
(send single active-child response-panel))
|
||||
(define pending-panel (new vertical-panel% (parent single)))
|
||||
(define pending-text (new html-text% (auto-wrap #t)))
|
||||
(define (reset-pending-text)
|
||||
(with-pending-text
|
||||
(λ ()
|
||||
(send pending-text erase)
|
||||
(render-html-to-text ; hack to get nice text in
|
||||
(open-input-string
|
||||
" <br><br><br><br><br><div align=\"center\"><h2><b>Submitting bug report...</b></h2></div>")
|
||||
pending-text #t #f))))
|
||||
(define (with-pending-text t)
|
||||
(send pending-text begin-edit-sequence)
|
||||
(send pending-text lock #f)
|
||||
(t)
|
||||
(send pending-text lock #t)
|
||||
(send pending-text end-edit-sequence))
|
||||
|
||||
(define pending-ec (new editor-canvas% [parent pending-panel] [editor pending-text]))
|
||||
(send pending-ec allow-tab-exit #t)
|
||||
|
||||
(define pending-button-panel (new horizontal-panel%
|
||||
[stretchable-height #f]
|
||||
[parent pending-panel]
|
||||
[alignment '(right center)]))
|
||||
(define pending-back (new button%
|
||||
[parent pending-button-panel]
|
||||
[callback (λ (x y) (switch-to-compose-view))]
|
||||
[label (string-constant dialog-back)]))
|
||||
(define pending-abort (new button%
|
||||
[parent pending-button-panel]
|
||||
[callback (lambda (x y) (custodian-shutdown-all cancel-kill-cust))]
|
||||
[label (string-constant abort)]))
|
||||
(new grow-box-spacer-pane% [parent pending-button-panel])
|
||||
|
||||
(define finished-panel (new vertical-panel% [parent single]))
|
||||
(define finished-ec (new editor-canvas% (parent finished-panel)))
|
||||
(send finished-ec allow-tab-exit #t)
|
||||
(define finished-button-panel (new horizontal-panel%
|
||||
[stretchable-height #f]
|
||||
[parent finished-panel]
|
||||
[alignment '(right center)]))
|
||||
(define finished-close (new button%
|
||||
[parent finished-button-panel]
|
||||
[enabled #t]
|
||||
[label (string-constant close)]
|
||||
[callback
|
||||
(lambda (x y)
|
||||
(send bug-frame close))]))
|
||||
(new grow-box-spacer-pane% [parent finished-button-panel])
|
||||
|
||||
(define (init-pending-view)
|
||||
(reset-pending-text)
|
||||
(send pending-back enable #f)
|
||||
(send pending-abort enable #t)
|
||||
(send single active-child pending-panel))
|
||||
|
||||
(define (switch-to-compose-view)
|
||||
(send single active-child outermost-panel)
|
||||
(send (if (string=? "" (preferences:get 'drracket:full-name))
|
||||
name
|
||||
summary)
|
||||
focus))
|
||||
(send single active-child compose-panel)
|
||||
(compose-view-focus))
|
||||
|
||||
(define lps null)
|
||||
|
||||
; build/label : ((union string (list-of string))
|
||||
; (area-container<%> -> item<%>)
|
||||
; boolean
|
||||
; area-container<%>
|
||||
; -> item<%>)
|
||||
; constructs and arranges the gui objects for the bug report form
|
||||
; effect: updates lps with the new label panel, for future alignment
|
||||
(define build/label
|
||||
(lambda (text make-item top? [stretch? #f] [top-panel top-panel] [vertical? #f])
|
||||
(define hp (make-object (if vertical?
|
||||
vertical-panel%
|
||||
horizontal-panel%)
|
||||
top-panel))
|
||||
(define lp (make-object vertical-panel% hp))
|
||||
(define ip (make-object vertical-panel% hp))
|
||||
(if (string? text)
|
||||
(make-object message% text lp)
|
||||
(map (lambda (s)
|
||||
(make-object message% s lp))
|
||||
text))
|
||||
(define item (make-item ip))
|
||||
(set! lps (cons lp lps))
|
||||
(unless stretch?
|
||||
(send hp stretchable-height #f)
|
||||
(send lp stretchable-height #f)
|
||||
(send ip stretchable-height #f))
|
||||
(send lp stretchable-width #f)
|
||||
(send lp stretchable-height #f)
|
||||
(send lp set-alignment (if vertical? 'left 'right) (if top? 'top 'center))
|
||||
(send ip set-alignment 'left 'top)
|
||||
item))
|
||||
|
||||
(define (align-labels)
|
||||
(let ([width (apply max (map (lambda (x) (send (car (send x get-children)) min-width))
|
||||
lps))])
|
||||
(for-each (lambda (x) (send x min-width width)) lps)))
|
||||
|
||||
(define name
|
||||
(build/label
|
||||
(string-constant bug-report-field-name)
|
||||
(lambda (panel)
|
||||
(keymap:call/text-keymap-initializer
|
||||
(lambda ()
|
||||
(make-object text-field% #f panel
|
||||
(lambda (text event)
|
||||
(preferences:set 'drracket:full-name (send text get-value)))
|
||||
(preferences:get 'drracket:full-name)))))
|
||||
#f))
|
||||
|
||||
(define email
|
||||
(build/label
|
||||
(string-constant bug-report-field-email)
|
||||
(lambda (panel)
|
||||
(keymap:call/text-keymap-initializer
|
||||
(lambda ()
|
||||
(make-object text-field% #f panel
|
||||
(lambda (text event)
|
||||
(preferences:set 'drracket:email (send text get-value)))
|
||||
(preferences:get 'drracket:email)))))
|
||||
#f))
|
||||
|
||||
(define summary
|
||||
(build/label
|
||||
(string-constant bug-report-field-summary)
|
||||
(lambda (panel)
|
||||
(keymap:call/text-keymap-initializer
|
||||
(lambda ()
|
||||
(make-object text-field% #f panel void))))
|
||||
#f))
|
||||
|
||||
(define severity
|
||||
(build/label
|
||||
(string-constant bug-report-field-severity)
|
||||
(lambda (panel)
|
||||
(make-object choice%
|
||||
#f
|
||||
(list "critical" "serious" "non-critical")
|
||||
panel
|
||||
void))
|
||||
#f))
|
||||
|
||||
(define bug-classes '(("software bug" "sw-bug")
|
||||
("documentation bug" "doc-bug")
|
||||
("change request" "change-request")
|
||||
("support" "support")))
|
||||
|
||||
(define bug-class
|
||||
(build/label
|
||||
(string-constant bug-report-field-class)
|
||||
(lambda (panel)
|
||||
(make-object choice%
|
||||
#f
|
||||
(map car bug-classes)
|
||||
panel
|
||||
void))
|
||||
#f))
|
||||
|
||||
(define (translate-class class)
|
||||
(cadr (assoc class bug-classes)))
|
||||
|
||||
(define (make-big-text label . args)
|
||||
(let ([canvas
|
||||
(apply
|
||||
build/label
|
||||
label
|
||||
(lambda (panel)
|
||||
(let* ([text (new (editor:standard-style-list-mixin
|
||||
(editor:keymap-mixin
|
||||
text:basic%)))]
|
||||
[canvas (new canvas:basic%
|
||||
(style '(hide-hscroll))
|
||||
(parent panel)
|
||||
(editor text))])
|
||||
(send text set-paste-text-only #t)
|
||||
(send text auto-wrap #t)
|
||||
(send text set-max-undo-history 'forever)
|
||||
(send text set-styles-fixed #t)
|
||||
canvas))
|
||||
#t
|
||||
args)])
|
||||
(send canvas min-width 500)
|
||||
(send canvas min-height 130)
|
||||
(send canvas get-editor)
|
||||
(send canvas allow-tab-exit #t)
|
||||
canvas))
|
||||
|
||||
(define description (make-big-text (string-constant bug-report-field-description) #t))
|
||||
(define reproduce (make-big-text (list (string-constant bug-report-field-reproduce1)
|
||||
(string-constant bug-report-field-reproduce2))
|
||||
#t))
|
||||
|
||||
(define synthesized-dialog (make-object dialog% (string-constant bug-report-synthesized-information)))
|
||||
(define synthesized-panel (make-object vertical-panel% synthesized-dialog))
|
||||
(define synthesized-button-panel
|
||||
(new horizontal-panel% [parent synthesized-dialog]
|
||||
[alignment '(right center)] [stretchable-height #f]))
|
||||
(define synthesized-ok-button (make-object button% (string-constant ok) synthesized-button-panel
|
||||
(lambda (x y)
|
||||
(send synthesized-dialog show #f))))
|
||||
(define synthesized-info-shown? #t)
|
||||
(define (show-synthesized-info)
|
||||
(send synthesized-dialog show #t))
|
||||
|
||||
(define version
|
||||
(build/label
|
||||
(string-constant bug-report-field-version)
|
||||
(lambda (panel)
|
||||
(keymap:call/text-keymap-initializer
|
||||
(lambda ()
|
||||
(make-object text-field% #f panel void ""))))
|
||||
#f
|
||||
#f
|
||||
synthesized-panel
|
||||
#f))
|
||||
(define environment
|
||||
(build/label
|
||||
(string-constant bug-report-field-environment)
|
||||
(lambda (panel)
|
||||
(keymap:call/text-keymap-initializer
|
||||
(lambda ()
|
||||
(make-object text-field% #f panel void ""))))
|
||||
#f
|
||||
#f
|
||||
synthesized-panel
|
||||
#f))
|
||||
|
||||
(define human-language
|
||||
(build/label
|
||||
(string-constant bug-report-field-human-language)
|
||||
(lambda (panel)
|
||||
(keymap:call/text-keymap-initializer
|
||||
(lambda ()
|
||||
(make-object text-field% #f panel void ""))))
|
||||
#f
|
||||
#f
|
||||
synthesized-panel))
|
||||
|
||||
(define memory-use
|
||||
(build/label
|
||||
(string-constant bug-report-field-memory-use)
|
||||
(lambda (panel)
|
||||
(keymap:call/text-keymap-initializer
|
||||
(lambda ()
|
||||
(make-object text-field% #f panel void ""))))
|
||||
#f
|
||||
#f
|
||||
synthesized-panel))
|
||||
|
||||
(define collections
|
||||
(make-big-text
|
||||
(string-constant bug-report-field-collections)
|
||||
#t
|
||||
synthesized-panel))
|
||||
|
||||
(define extras
|
||||
(map (lambda (bri)
|
||||
(let ([label (bri-label bri)])
|
||||
(cons
|
||||
label
|
||||
(build/label
|
||||
label
|
||||
(lambda (panel)
|
||||
(let ([field
|
||||
(keymap:call/text-keymap-initializer
|
||||
(lambda ()
|
||||
(make-object text-field% #f panel void "")))])
|
||||
(send field set-value (bri-value bri))
|
||||
field))
|
||||
#f
|
||||
#f
|
||||
synthesized-panel))))
|
||||
(get-bug-report-infos)))
|
||||
|
||||
(define button-panel
|
||||
(new horizontal-panel% [parent outermost-panel]
|
||||
[alignment '(right center)] [stretchable-height #f]))
|
||||
(define synthesized-button (make-object button%
|
||||
(string-constant bug-report-show-synthesized-info)
|
||||
button-panel (lambda x (show-synthesized-info))))
|
||||
(define _spacer (new horizontal-pane% (parent button-panel)))
|
||||
(define cancel-button (make-object button% (string-constant cancel) button-panel (lambda x (cancel))))
|
||||
(define ok-button (make-object button% (string-constant bug-report-submit) button-panel (lambda x (ok))))
|
||||
(define _grow-box
|
||||
(new grow-box-spacer-pane% [parent button-panel]))
|
||||
|
||||
(define (get-query)
|
||||
(append (list (cons 'help-desk "true")
|
||||
(cons 'replyto (preferences:get 'drracket:email))
|
||||
(cons 'originator (preferences:get 'drracket:full-name))
|
||||
(cons 'subject (send summary get-value))
|
||||
(cons 'severity (send severity get-string-selection))
|
||||
(cons 'class (translate-class (send bug-class get-string-selection)))
|
||||
(cons 'release (send version get-value))
|
||||
(cons 'description (apply string-append (map (lambda (x) (string-append x "\n"))
|
||||
(get-strings description))))
|
||||
(cons 'how-to-repeat (apply string-append
|
||||
(map (lambda (x) (string-append x "\n"))
|
||||
(get-strings reproduce))))
|
||||
(cons 'platform (get-environment)))
|
||||
(map (λ (bri) (cons (string->symbol (format "~a" (bri-label bri)))
|
||||
(bri-value bri)))
|
||||
(get-bug-report-infos))))
|
||||
|
||||
(define (get-environment)
|
||||
(string-append (send environment get-value)
|
||||
"\n"
|
||||
(format "Human Language: ~a\n" (send human-language get-value))
|
||||
(format "(current-memory-use) ~a\n" (send memory-use get-value))
|
||||
"\nCollections:\n"
|
||||
(format "~a" (send (send collections get-editor) get-text))
|
||||
"\n"
|
||||
(apply
|
||||
string-append
|
||||
(map (lambda (extra)
|
||||
(format "~a: ~a\n"
|
||||
(car extra)
|
||||
(send (cdr extra) get-value)))
|
||||
extras))))
|
||||
;; important that you cannot go back from this view,
|
||||
;; or else that might trigger saving the bug report in the preferences
|
||||
;; (but when you're here the bug report should be succesfully submitted)
|
||||
(define (switch-to-finished-view finished-text)
|
||||
(send finished-ec set-editor finished-text)
|
||||
(unsave-bug-report (saved-report-id init-bug-report))
|
||||
(send single active-child finished-panel))
|
||||
|
||||
; send-bug-report : (-> void)
|
||||
;; initiates sending the bug report and switches the GUI's mode
|
||||
(define (send-bug-report)
|
||||
(letrec ([query (get-query)]
|
||||
[url
|
||||
(string->url (format "http://~a:~a/cgi-bin/bug-report"
|
||||
bug-www-server
|
||||
bug-www-server-port))]
|
||||
[post-data
|
||||
(parameterize ([current-alist-separator-mode 'amp])
|
||||
(string->bytes/utf-8 (alist->form-urlencoded query)))]
|
||||
[http-thread
|
||||
(parameterize ([current-custodian (make-custodian)])
|
||||
(thread
|
||||
(lambda ()
|
||||
(with-handlers ([(lambda (x) (exn:break? x))
|
||||
(lambda (x) (void))]
|
||||
[(lambda (x) (not (exn:break? x)))
|
||||
(lambda (x)
|
||||
(queue-callback
|
||||
(lambda ()
|
||||
(switch-to-compose-view)
|
||||
(message-box
|
||||
(string-constant error-sending-bug-report)
|
||||
(format (string-constant error-sending-bug-report-expln)
|
||||
(if (exn? x)
|
||||
(exn-message x)
|
||||
(format "~s" x)))))))])
|
||||
(parameterize ([current-alist-separator-mode 'amp])
|
||||
(call/input-url
|
||||
url
|
||||
(case-lambda
|
||||
[(x) (post-pure-port x post-data)]
|
||||
[(x y) (post-pure-port x post-data y)])
|
||||
(lambda (port)
|
||||
(send response-text lock #f)
|
||||
(send response-text erase)
|
||||
(render-html-to-text port response-text #t #f)
|
||||
(send response-text lock #t))))
|
||||
(queue-callback
|
||||
(lambda ()
|
||||
(send response-abort enable #f)
|
||||
(send response-reset enable #t)
|
||||
(send response-close enable #t)
|
||||
(set! cancel-kill-thread #f)
|
||||
(send bug-frame set-ok-to-close #t)
|
||||
(send response-close focus)))))))])
|
||||
(set! cancel-kill-thread http-thread)
|
||||
(send response-abort enable #t)
|
||||
(switch-to-response-view)))
|
||||
|
||||
(define (get-strings canvas)
|
||||
(let ([t (send canvas get-editor)])
|
||||
(let loop ([n 0])
|
||||
(cond
|
||||
[(> n (send t last-paragraph)) null]
|
||||
[else (cons (send t get-text
|
||||
(send t paragraph-start-position n)
|
||||
(send t paragraph-end-position n))
|
||||
(loop (+ n 1)))]))))
|
||||
|
||||
(define (sanity-checking)
|
||||
(let ([no-value?
|
||||
(lambda (f)
|
||||
(cond
|
||||
[(is-a? f editor-canvas%)
|
||||
(= 0 (send (send f get-editor) last-position))]
|
||||
[else (string=? "" (send f get-value))]))])
|
||||
(let/ec done-checking
|
||||
(for-each
|
||||
(lambda (field field-name)
|
||||
(when (no-value? field)
|
||||
(message-box (string-constant illegal-bug-report)
|
||||
(format (string-constant pls-fill-in-field) field-name))
|
||||
(done-checking #f)))
|
||||
(list name summary)
|
||||
(list (string-constant bug-report-field-name)
|
||||
(string-constant bug-report-field-summary)))
|
||||
|
||||
(when (and (no-value? description)
|
||||
(no-value? reproduce))
|
||||
(message-box (string-constant illegal-bug-report)
|
||||
(string-constant pls-fill-in-either-description-or-reproduce))
|
||||
(done-checking #f))
|
||||
|
||||
(unless (regexp-match #rx"@" (or (preferences:get 'drracket:email) ""))
|
||||
(message-box (string-constant illegal-bug-report)
|
||||
(string-constant malformed-email-address))
|
||||
(done-checking #f))
|
||||
(done-checking #t))))
|
||||
|
||||
(define query (get-query))
|
||||
(define url
|
||||
(string->url (format "http://~a:~a/cgi-bin/bug-report"
|
||||
bug-www-server
|
||||
bug-www-server-port)))
|
||||
(define post-data
|
||||
(parameterize ([current-alist-separator-mode 'amp])
|
||||
(string->bytes/utf-8 (alist->form-urlencoded query))))
|
||||
(set! cancel-kill-cust (make-custodian))
|
||||
(define response-chan (make-channel))
|
||||
(define exn-chan (make-channel))
|
||||
(define worker-thread
|
||||
(parameterize ([current-custodian cancel-kill-cust])
|
||||
(thread
|
||||
(λ ()
|
||||
(with-handlers ([exn:fail? (λ (x) (channel-put exn-chan x))])
|
||||
(parameterize ([current-alist-separator-mode 'amp])
|
||||
(call/input-url
|
||||
url
|
||||
(case-lambda
|
||||
[(x) (post-pure-port x post-data)]
|
||||
[(x y) (post-pure-port x post-data y)])
|
||||
(lambda (port)
|
||||
(define response-text (new html-text%))
|
||||
(render-html-to-text port response-text #t #f)
|
||||
(send response-text auto-wrap #t)
|
||||
(send response-text lock #t)
|
||||
(channel-put response-chan response-text)))))))))
|
||||
|
||||
(thread
|
||||
(λ ()
|
||||
(sync
|
||||
(handle-evt
|
||||
exn-chan
|
||||
(λ (exn)
|
||||
(queue-callback
|
||||
(λ ()
|
||||
(define sp (open-output-string))
|
||||
(define-values (in out) (make-pipe))
|
||||
(thread
|
||||
(λ ()
|
||||
(fprintf out "<pre>\n")
|
||||
(display (exn-message exn) out)
|
||||
(fprintf out "\n</pre>\n")
|
||||
(close-output-port out)))
|
||||
(with-pending-text
|
||||
(λ () (render-html-to-text in pending-text #t #f)))
|
||||
(send pending-back enable #t)
|
||||
(send pending-abort enable #f)))))
|
||||
(handle-evt
|
||||
(thread-dead-evt worker-thread)
|
||||
(λ (_)
|
||||
(queue-callback
|
||||
(λ ()
|
||||
(with-pending-text
|
||||
(λ ()
|
||||
(define p (send pending-text last-position))
|
||||
(send pending-text insert "Killed." p p)))
|
||||
(send pending-back enable #t)
|
||||
(send pending-abort enable #f)))))
|
||||
(handle-evt
|
||||
response-chan
|
||||
(λ (finished-text)
|
||||
(queue-callback
|
||||
(lambda ()
|
||||
(switch-to-finished-view finished-text))))))))
|
||||
|
||||
(init-pending-view))
|
||||
|
||||
(define (ok)
|
||||
(when (sanity-checking)
|
||||
(send-bug-report)))
|
||||
|
||||
(define (cancel)
|
||||
(cleanup-frame))
|
||||
(when (ask-yes-or-no (string-constant cancel-bug-report?)
|
||||
(string-constant are-you-sure-cancel-bug-report?)
|
||||
bug-frame)
|
||||
(unsave-bug-report (saved-report-id init-bug-report))
|
||||
(send bug-frame close)))
|
||||
|
||||
(define (cleanup-frame)
|
||||
(define (close-and-save)
|
||||
(send bug-frame close))
|
||||
|
||||
(define (directories-contents dirs)
|
||||
(map (lambda (d)
|
||||
(cons (path->string d)
|
||||
(if (directory-exists? d)
|
||||
(map path->string (directory-list d))
|
||||
'(non-existent-path))))
|
||||
dirs))
|
||||
|
||||
(define (split-by-directories dirs split-by)
|
||||
(let ([res (append (map list (map path->string split-by)) '((*)))]
|
||||
[dirs (map path->string dirs)])
|
||||
(for-each
|
||||
(lambda (d)
|
||||
(let* ([l (string-length d)]
|
||||
[x (assf
|
||||
(lambda (d2)
|
||||
(or (eq? d2 '*)
|
||||
(let ([l2 (string-length d2)])
|
||||
(and (< l2 l) (equal? d2 (substring d 0 l2))
|
||||
(member (string-ref d l2) '(#\/ #\\))))))
|
||||
res)])
|
||||
(append x (list (if (string? (car x))
|
||||
(substring d (add1 (string-length (car x))))
|
||||
d)))))
|
||||
dirs)
|
||||
(filter (lambda (x) (pair? (cdr x))) res)))
|
||||
|
||||
(send response-ec allow-tab-exit #t)
|
||||
|
||||
(send severity set-selection 1)
|
||||
(send version set-value (format "~a" (version:version)))
|
||||
|
||||
(send environment set-value
|
||||
(format "~a ~s (~a) (get-display-depth) = ~a"
|
||||
(system-type)
|
||||
(system-type 'machine)
|
||||
(system-library-subpath)
|
||||
(get-display-depth)))
|
||||
|
||||
(send (send collections get-editor)
|
||||
insert
|
||||
(format "~s" (directories-contents (get-collects-search-dirs))))
|
||||
|
||||
(send human-language set-value (format "~a" (this-language)))
|
||||
(send memory-use set-value (format "~a" (current-memory-use)))
|
||||
|
||||
(send (send collections get-editor) auto-wrap #t)
|
||||
|
||||
;; Currently, the help-menu is left empty
|
||||
(frame:remove-empty-menus bug-frame)
|
||||
|
||||
(align-labels)
|
||||
(switch-to-compose-view)
|
||||
|
||||
(send bug-frame show #t))
|
||||
|
||||
(define html-text% (text:hide-caret/selection-mixin (html-text-mixin text:basic%)))
|
||||
|
||||
(define (ask-yes-or-no title msg parent)
|
||||
(gui-utils:get-choice msg
|
||||
(string-constant yes)
|
||||
|
|
|
|||
405
collects/help/private/bug-report-controls.rkt
Normal file
405
collects/help/private/bug-report-controls.rkt
Normal file
|
|
@ -0,0 +1,405 @@
|
|||
#lang racket/base
|
||||
(require racket/gui/base
|
||||
racket/class
|
||||
racket/contract
|
||||
racket/pretty
|
||||
string-constants/string-constant
|
||||
setup/dirs
|
||||
framework
|
||||
"buginfo.ss"
|
||||
"save-bug-report.rkt")
|
||||
|
||||
(provide/contract
|
||||
[add-bug-report-controls
|
||||
(-> (is-a?/c area-container<%>)
|
||||
saved-report?
|
||||
(-> any)
|
||||
(-> any)
|
||||
(-> any)
|
||||
any)])
|
||||
|
||||
(define (add-bug-report-controls compose-panel init-bug-report ok cancel close-and-save)
|
||||
(define top-panel (make-object vertical-panel% compose-panel))
|
||||
|
||||
(define lps null)
|
||||
|
||||
; build/label : ((union string (list-of string))
|
||||
; (area-container<%> -> item<%>)
|
||||
; boolean
|
||||
; area-container<%>
|
||||
; -> item<%>)
|
||||
; constructs and arranges the gui objects for the bug report form
|
||||
; effect: updates lps with the new label panel, for future alignment
|
||||
(define (build/label text make-item top? #:stretch? [stretch? #f] #:top-panel [top-panel top-panel] #:vertical? [vertical? #f])
|
||||
(define hp (make-object (if vertical?
|
||||
vertical-panel%
|
||||
horizontal-panel%)
|
||||
top-panel))
|
||||
(define lp (make-object vertical-panel% hp))
|
||||
(define ip (make-object vertical-panel% hp))
|
||||
(if (string? text)
|
||||
(make-object message% text lp)
|
||||
(map (lambda (s)
|
||||
(make-object message% s lp))
|
||||
text))
|
||||
(define item (make-item ip))
|
||||
(set! lps (cons lp lps))
|
||||
(unless stretch?
|
||||
(send hp stretchable-height #f)
|
||||
(send lp stretchable-height #f)
|
||||
(send ip stretchable-height #f))
|
||||
(send lp stretchable-width #f)
|
||||
(send lp stretchable-height #f)
|
||||
(send lp set-alignment (if vertical? 'left 'right) (if top? 'top 'center))
|
||||
(send ip set-alignment 'left 'top)
|
||||
item)
|
||||
|
||||
(define (align-labels)
|
||||
(send synthesized-dialog reflow-container)
|
||||
(send compose-panel reflow-container)
|
||||
(let ([width (apply max (map (lambda (x) (send (car (send x get-children)) get-width))
|
||||
lps))])
|
||||
(for ([x (in-list lps)])
|
||||
(send x min-width width))))
|
||||
|
||||
(define name
|
||||
(build/label
|
||||
(string-constant bug-report-field-name)
|
||||
(lambda (panel)
|
||||
(keymap:call/text-keymap-initializer
|
||||
(lambda ()
|
||||
(make-object text-field% #f panel
|
||||
(lambda (text event)
|
||||
(preferences:set 'drracket:full-name (send text get-value)))
|
||||
(preferences:get 'drracket:full-name)))))
|
||||
#f))
|
||||
|
||||
(define email
|
||||
(build/label
|
||||
(string-constant bug-report-field-email)
|
||||
(lambda (panel)
|
||||
(keymap:call/text-keymap-initializer
|
||||
(lambda ()
|
||||
(make-object text-field% #f panel
|
||||
(lambda (text event)
|
||||
(preferences:set 'drracket:email (send text get-value)))
|
||||
(preferences:get 'drracket:email)))))
|
||||
#f))
|
||||
|
||||
(define summary
|
||||
(build/label
|
||||
(string-constant bug-report-field-summary)
|
||||
(lambda (panel)
|
||||
(keymap:call/text-keymap-initializer
|
||||
(lambda ()
|
||||
(define tf (new text-field%
|
||||
[label #f]
|
||||
[parent panel]
|
||||
[callback (λ (a b) (bug-report-out-of-date))]))
|
||||
(send tf set-value (saved-report-lookup init-bug-report 'subject))
|
||||
tf)))
|
||||
#f))
|
||||
|
||||
(define severity
|
||||
(build/label
|
||||
(string-constant bug-report-field-severity)
|
||||
(lambda (panel)
|
||||
(define choice
|
||||
(make-object choice%
|
||||
#f
|
||||
bug-severities
|
||||
panel
|
||||
(λ (a b) (bug-report-out-of-date))))
|
||||
(send choice set-string-selection (saved-report-lookup init-bug-report 'severity))
|
||||
choice)
|
||||
#f))
|
||||
|
||||
(define bug-class
|
||||
(build/label
|
||||
(string-constant bug-report-field-class)
|
||||
(lambda (panel)
|
||||
(define choice (make-object choice%
|
||||
#f
|
||||
(map car bug-classes)
|
||||
panel
|
||||
(λ (a b) (bug-report-out-of-date))))
|
||||
(send choice set-string-selection
|
||||
(saved-report-lookup init-bug-report 'class))
|
||||
choice)
|
||||
#f))
|
||||
|
||||
(define save-text%
|
||||
(class text:basic%
|
||||
(define initialized? #f)
|
||||
(define/public (initialized) (set! initialized? #t))
|
||||
(define/augment (after-insert a b)
|
||||
(when initialized?
|
||||
(bug-report-out-of-date))
|
||||
(inner (void) after-insert a b))
|
||||
(define/augment (after-delete a b)
|
||||
(when initialized?
|
||||
(bug-report-out-of-date))
|
||||
(inner (void) after-delete a b))
|
||||
(super-new)))
|
||||
|
||||
(define (make-big-text label #:key [key #f] #:stretch? [stretch? #f] #:top-panel [top-panel top-panel] #:vertical? [vertical? #f])
|
||||
(let ([canvas
|
||||
(build/label
|
||||
label
|
||||
(lambda (panel)
|
||||
(let* ([text (new (editor:standard-style-list-mixin
|
||||
(editor:keymap-mixin
|
||||
(if key
|
||||
save-text%
|
||||
text:basic%))))]
|
||||
[canvas (new canvas:basic%
|
||||
(style '(hide-hscroll))
|
||||
(parent panel)
|
||||
(editor text))])
|
||||
(send text set-paste-text-only #t)
|
||||
(send text auto-wrap #t)
|
||||
(send text set-max-undo-history 'forever)
|
||||
(send text set-styles-fixed #t)
|
||||
(when key
|
||||
(send text insert (saved-report-lookup init-bug-report key))
|
||||
(send text set-position 0 0)
|
||||
(send text initialized))
|
||||
canvas))
|
||||
#t
|
||||
#:stretch? stretch?
|
||||
#:top-panel top-panel
|
||||
#:vertical? vertical?)])
|
||||
(send canvas min-width 500)
|
||||
(send canvas min-height 130)
|
||||
(send canvas get-editor)
|
||||
(send canvas allow-tab-exit #t)
|
||||
canvas))
|
||||
|
||||
(define description (make-big-text (string-constant bug-report-field-description)
|
||||
#:key 'description
|
||||
#:stretch? #t))
|
||||
(define reproduce (make-big-text (list (string-constant bug-report-field-reproduce1)
|
||||
(string-constant bug-report-field-reproduce2))
|
||||
#:key 'how-to-repeat
|
||||
#:stretch? #t))
|
||||
|
||||
(define synthesized-dialog (make-object dialog% (string-constant bug-report-synthesized-information)))
|
||||
(define synthesized-panel (make-object vertical-panel% synthesized-dialog))
|
||||
(define synthesized-button-panel
|
||||
(new horizontal-panel% [parent synthesized-dialog]
|
||||
[alignment '(right center)] [stretchable-height #f]))
|
||||
(define synthesized-ok-button (make-object button% (string-constant ok) synthesized-button-panel
|
||||
(lambda (x y)
|
||||
(send synthesized-dialog show #f))))
|
||||
(define synthesized-info-shown? #t)
|
||||
(define (show-synthesized-info)
|
||||
(send synthesized-dialog show #t))
|
||||
|
||||
(define version-tf
|
||||
(build/label
|
||||
(string-constant bug-report-field-version)
|
||||
(lambda (panel)
|
||||
(keymap:call/text-keymap-initializer
|
||||
(lambda ()
|
||||
(make-object text-field% #f panel void ""))))
|
||||
#f
|
||||
#:top-panel synthesized-panel))
|
||||
(define environment
|
||||
(build/label
|
||||
(string-constant bug-report-field-environment)
|
||||
(lambda (panel)
|
||||
(keymap:call/text-keymap-initializer
|
||||
(lambda ()
|
||||
(make-object text-field% #f panel void ""))))
|
||||
#f
|
||||
#:top-panel synthesized-panel))
|
||||
|
||||
(define human-language
|
||||
(build/label
|
||||
(string-constant bug-report-field-human-language)
|
||||
(lambda (panel)
|
||||
(keymap:call/text-keymap-initializer
|
||||
(lambda ()
|
||||
(make-object text-field% #f panel void ""))))
|
||||
#f
|
||||
#:top-panel synthesized-panel))
|
||||
|
||||
(define memory-use
|
||||
(build/label
|
||||
(string-constant bug-report-field-memory-use)
|
||||
(lambda (panel)
|
||||
(keymap:call/text-keymap-initializer
|
||||
(lambda ()
|
||||
(make-object text-field% #f panel void ""))))
|
||||
#f
|
||||
#:top-panel synthesized-panel))
|
||||
|
||||
(define collections
|
||||
(make-big-text
|
||||
(string-constant bug-report-field-collections)
|
||||
#:stretch? #t
|
||||
#:top-panel synthesized-panel))
|
||||
|
||||
(send synthesized-dialog reflow-container) ;; help out the editor by resizing the container to a reasonable width (and thus make word-wrapping easier)
|
||||
|
||||
(define extras
|
||||
(map (lambda (bri)
|
||||
(let ([label (bri-label bri)])
|
||||
(cons
|
||||
label
|
||||
(build/label
|
||||
label
|
||||
(lambda (panel)
|
||||
(let ([field
|
||||
(keymap:call/text-keymap-initializer
|
||||
(lambda ()
|
||||
(make-object text-field% #f panel void "")))])
|
||||
(send field set-value (bri-value bri))
|
||||
field))
|
||||
#f
|
||||
#:top-panel synthesized-panel))))
|
||||
(get-bug-report-infos)))
|
||||
|
||||
(define (save-this-bug-report)
|
||||
(save-bug-report
|
||||
(saved-report-id init-bug-report)
|
||||
#:severity (send severity get-string-selection)
|
||||
#:class (send bug-class get-string-selection)
|
||||
#:subject (send summary get-value)
|
||||
#:description (get-content description)
|
||||
#:how-to-repeat (get-content reproduce)))
|
||||
|
||||
(define timer
|
||||
(new timer%
|
||||
[notify-callback save-this-bug-report]
|
||||
[just-once? #t]))
|
||||
(define (bug-report-out-of-date)
|
||||
(send timer stop)
|
||||
(send timer start 200 #t))
|
||||
|
||||
(define (get-query)
|
||||
(append (list (cons 'help-desk "true")
|
||||
(cons 'replyto (preferences:get 'drracket:email))
|
||||
(cons 'originator (preferences:get 'drracket:full-name))
|
||||
(cons 'subject (send summary get-value))
|
||||
(cons 'severity (send severity get-string-selection))
|
||||
(cons 'class (translate-class (send bug-class get-string-selection)))
|
||||
(cons 'release (send version-tf get-value))
|
||||
(cons 'description (get-content description))
|
||||
(cons 'how-to-repeat (get-content reproduce))
|
||||
(cons 'platform (get-environment)))
|
||||
(map (λ (bri) (cons (string->symbol (format "~a" (bri-label bri)))
|
||||
(bri-value bri)))
|
||||
(get-bug-report-infos))))
|
||||
|
||||
(define (get-environment)
|
||||
(string-append (send environment get-value)
|
||||
"\n"
|
||||
(format "Human Language: ~a\n" (send human-language get-value))
|
||||
(format "(current-memory-use) ~a\n" (send memory-use get-value))
|
||||
"\nCollections:\n"
|
||||
(format "~a" (send (send collections get-editor) get-text))
|
||||
"\n"
|
||||
(apply
|
||||
string-append
|
||||
(map (lambda (extra)
|
||||
(format "~a: ~a\n"
|
||||
(car extra)
|
||||
(send (cdr extra) get-value)))
|
||||
extras))))
|
||||
|
||||
(define (get-content canvas)
|
||||
(define t (send canvas get-editor))
|
||||
(send t get-text 0 (send t last-position)))
|
||||
|
||||
(define (set-content canvas str)
|
||||
(define t (send canvas get-editor))
|
||||
(send t begin-edit-sequence)
|
||||
(send t erase)
|
||||
(send t insert str)
|
||||
(send t end-edit-sequence))
|
||||
|
||||
(define (compose-view-focus)
|
||||
(send (if (string=? "" (preferences:get 'drracket:full-name))
|
||||
name
|
||||
summary)
|
||||
focus))
|
||||
|
||||
(define button-panel
|
||||
(new horizontal-panel% [parent compose-panel]
|
||||
[alignment '(right center)] [stretchable-height #f]))
|
||||
(define synthesized-button
|
||||
(make-object button%
|
||||
(string-constant bug-report-show-synthesized-info)
|
||||
button-panel (lambda x (show-synthesized-info))))
|
||||
(new horizontal-pane% (parent button-panel))
|
||||
(new button%
|
||||
[parent button-panel]
|
||||
[label (string-constant close-and-save)]
|
||||
[callback (λ (a b) (close-and-save))])
|
||||
(gui-utils:ok/cancel-buttons button-panel
|
||||
(λ (a b) (ok))
|
||||
(λ (a b) (cancel))
|
||||
(string-constant bug-report-submit))
|
||||
(new grow-box-spacer-pane% [parent button-panel])
|
||||
|
||||
|
||||
(define (sanity-checking)
|
||||
(let ([no-value?
|
||||
(lambda (f)
|
||||
(cond
|
||||
[(is-a? f editor-canvas%)
|
||||
(= 0 (send (send f get-editor) last-position))]
|
||||
[else (string=? "" (send f get-value))]))])
|
||||
(let/ec done-checking
|
||||
(for-each
|
||||
(lambda (field field-name)
|
||||
(when (no-value? field)
|
||||
(message-box (string-constant illegal-bug-report)
|
||||
(format (string-constant pls-fill-in-field) field-name))
|
||||
(done-checking #f)))
|
||||
(list name summary)
|
||||
(list (string-constant bug-report-field-name)
|
||||
(string-constant bug-report-field-summary)))
|
||||
|
||||
(when (and (no-value? description)
|
||||
(no-value? reproduce))
|
||||
(message-box (string-constant illegal-bug-report)
|
||||
(string-constant pls-fill-in-either-description-or-reproduce))
|
||||
(done-checking #f))
|
||||
|
||||
(unless (regexp-match #rx"@" (or (preferences:get 'drracket:email) ""))
|
||||
(message-box (string-constant illegal-bug-report)
|
||||
(string-constant malformed-email-address))
|
||||
(done-checking #f))
|
||||
(done-checking #t))))
|
||||
|
||||
(send version-tf set-value (format "~a" (version:version)))
|
||||
|
||||
(send environment set-value
|
||||
(format "~a ~s (~a) (get-display-depth) = ~a"
|
||||
(system-type)
|
||||
(system-type 'machine)
|
||||
(system-library-subpath)
|
||||
(get-display-depth)))
|
||||
|
||||
(send (send collections get-editor)
|
||||
insert
|
||||
(apply
|
||||
string-append
|
||||
(for/list ([d (get-collects-search-dirs)])
|
||||
(format "(~s\n ~s)\n"
|
||||
(path->string d)
|
||||
(if (directory-exists? d)
|
||||
(map path->string (directory-list d))
|
||||
'(non-existent-path))))))
|
||||
|
||||
(send human-language set-value (format "~a" (this-language)))
|
||||
(send memory-use set-value (format "~a" (current-memory-use)))
|
||||
|
||||
(send (send collections get-editor) auto-wrap #t)
|
||||
(align-labels)
|
||||
|
||||
(values compose-view-focus
|
||||
get-query
|
||||
sanity-checking))
|
||||
|
|
@ -1,17 +1,17 @@
|
|||
#lang mzscheme
|
||||
#lang racket/base
|
||||
|
||||
(provide set-bug-report-info!
|
||||
get-bug-report-infos
|
||||
bri-label
|
||||
bri-value)
|
||||
|
||||
(define-struct bri (label get-value))
|
||||
(struct bri (label get-value) #:transparent)
|
||||
(define (bri-value bri) ((bri-get-value bri)))
|
||||
|
||||
;; update with symbol/string assoc list
|
||||
(define bug-report-infos null)
|
||||
|
||||
(define (set-bug-report-info! str thunk)
|
||||
(set! bug-report-infos (cons (make-bri str thunk) bug-report-infos)))
|
||||
(set! bug-report-infos (cons (bri str thunk) bug-report-infos)))
|
||||
|
||||
(define (get-bug-report-infos) bug-report-infos)
|
||||
|
|
|
|||
200
collects/help/private/save-bug-report.rkt
Normal file
200
collects/help/private/save-bug-report.rkt
Normal file
|
|
@ -0,0 +1,200 @@
|
|||
#lang racket/base
|
||||
|
||||
#|
|
||||
|
||||
If there are saved reports when a window opens, offer to open the saved ones.
|
||||
|
||||
Put the saved things in the help menu.
|
||||
|
||||
|#
|
||||
|
||||
(require racket/match
|
||||
racket/contract
|
||||
racket/serialize
|
||||
racket/list
|
||||
framework/preferences)
|
||||
|
||||
(define bug-classes '(("software bug" "sw-bug")
|
||||
("documentation bug" "doc-bug")
|
||||
("change request" "change-request")
|
||||
("support" "support")))
|
||||
|
||||
(define (translate-class class)
|
||||
(cadr (assoc class bug-classes)))
|
||||
|
||||
(define bug-severities '("critical" "serious" "non-critical"))
|
||||
|
||||
(define (with-pref func #:rewrite? rewrite?)
|
||||
(define old (preferences:get 'drracket:unfinished-bug-reports))
|
||||
(define ans (func old))
|
||||
(if rewrite?
|
||||
(preferences:set 'drracket:unfinished-bug-reports ans)
|
||||
ans))
|
||||
|
||||
(define (discard-all-except f)
|
||||
(with-pref
|
||||
#:rewrite? #t
|
||||
(λ (exp)
|
||||
(filter (λ (saved-report) (f (saved-report-id saved-report)))
|
||||
exp))))
|
||||
|
||||
(define valid-keys (sort '(severity
|
||||
class
|
||||
subject
|
||||
description
|
||||
how-to-repeat)
|
||||
string<=?
|
||||
#:key symbol->string))
|
||||
|
||||
;; id : number
|
||||
;; open? : boolean?
|
||||
;; table : (listof (list sym string?))
|
||||
;; (the above are only an upper bound on the constraints here;
|
||||
;; see validate for more info)
|
||||
(serializable-struct saved-report (id table) #:transparent)
|
||||
|
||||
(define (blank-bug-form id)
|
||||
(saved-report id
|
||||
(for/list ([key (in-list valid-keys)])
|
||||
(list key
|
||||
(case key
|
||||
[(class) (car (car bug-classes))]
|
||||
[(severity) (list-ref bug-severities 1)]
|
||||
[else ""])))))
|
||||
|
||||
|
||||
;; valid? : any -> boolean?
|
||||
;; returns #t if the saved-reports are well formed
|
||||
(define (valid? saved-reports)
|
||||
(cond
|
||||
[(list? saved-reports)
|
||||
(and (for/and ([saved-report (in-list saved-reports)])
|
||||
(validate-single saved-report))
|
||||
(no-dups (map saved-report-id saved-reports)))]
|
||||
[else #f]))
|
||||
|
||||
(define (no-dups l) (equal? l (remove-duplicates l)))
|
||||
|
||||
(define (validate-single a-saved-report)
|
||||
(match a-saved-report
|
||||
[(struct saved-report ((? number?)
|
||||
(list (list (? symbol? keys) vals) ...)))
|
||||
(and (equal? (sort keys string<=? #:key symbol->string)
|
||||
valid-keys)
|
||||
(for/and ([key (in-list keys)]
|
||||
[val (in-list vals)])
|
||||
(case key
|
||||
[(class) (member val (map car bug-classes))]
|
||||
[(severity) (member val bug-severities)]
|
||||
[else (string? val)])))]
|
||||
[else #f]))
|
||||
|
||||
(define (register-new-bug-id)
|
||||
(define ans #f)
|
||||
(with-pref
|
||||
#:rewrite? #t
|
||||
(λ (bug-reports)
|
||||
(define ids (map saved-report-id bug-reports))
|
||||
(define new-id
|
||||
(let loop ([i 0])
|
||||
(cond
|
||||
[(member i ids)
|
||||
(loop (+ i 1))]
|
||||
[else
|
||||
i])))
|
||||
(set! ans (blank-bug-form new-id))
|
||||
(cons ans bug-reports)))
|
||||
ans)
|
||||
|
||||
;; title : label-string?
|
||||
;; id : number?
|
||||
(struct brinfo (title id) #:transparent)
|
||||
|
||||
(define (saved-bug-report-titles/ids)
|
||||
(with-pref
|
||||
#:rewrite? #f
|
||||
(λ (x)
|
||||
(for/list ([a-saved-report (in-list x)])
|
||||
(define assoc-l (saved-report-table a-saved-report))
|
||||
(define subj-p (assoc 'subject assoc-l))
|
||||
(brinfo (trim-to-200 (regexp-replace* #rx"&" (cadr subj-p) "&&"))
|
||||
(saved-report-id a-saved-report))))))
|
||||
|
||||
(define (trim-to-200 str)
|
||||
(cond
|
||||
[(<= (string-length str) 200)
|
||||
str]
|
||||
[else
|
||||
(define len (string-length str))
|
||||
(define spacer " ... ")
|
||||
(string-append
|
||||
(substring str 0 100)
|
||||
spacer
|
||||
(substring str (+ (- len 100) (string-length spacer)) len))]))
|
||||
|
||||
(define (lookup-bug-report id)
|
||||
(or (with-pref
|
||||
#:rewrite? #f
|
||||
(λ (exp)
|
||||
(ormap (λ (x) (and (equal? id (saved-report-id x)) x))
|
||||
exp)))
|
||||
(register-new-bug-id)))
|
||||
|
||||
(define (saved-report-lookup a-saved-report key)
|
||||
(cadr (assoc key (saved-report-table a-saved-report))))
|
||||
|
||||
(define (save-bug-report id
|
||||
#:severity severity
|
||||
#:class class
|
||||
#:subject subject
|
||||
#:description description
|
||||
#:how-to-repeat how-to-repeat)
|
||||
(with-pref
|
||||
#:rewrite? #t
|
||||
(λ (reports)
|
||||
(cons
|
||||
(saved-report id (list (list 'severity severity)
|
||||
(list 'class class)
|
||||
(list 'subject subject)
|
||||
(list 'description description)
|
||||
(list 'how-to-repeat how-to-repeat)))
|
||||
(filter (λ (saved-report)
|
||||
(not (equal? id (saved-report-id saved-report))))
|
||||
reports)))))
|
||||
|
||||
(define (unsave-bug-report id)
|
||||
(with-pref
|
||||
#:rewrite? #t
|
||||
(λ (reports)
|
||||
(filter (λ (saved-report) (not (equal? id (saved-report-id saved-report))))
|
||||
reports))))
|
||||
|
||||
(preferences:set-default 'drracket:unfinished-bug-reports
|
||||
'()
|
||||
valid?)
|
||||
(preferences:set-un/marshall 'drracket:unfinished-bug-reports
|
||||
serialize
|
||||
(λ (x)
|
||||
(with-handlers ((exn:fail? (λ (exn) '())))
|
||||
(deserialize x))))
|
||||
|
||||
(provide bug-severities
|
||||
bug-classes
|
||||
translate-class
|
||||
(struct-out brinfo)
|
||||
saved-report?)
|
||||
(provide/contract
|
||||
[register-new-bug-id (-> saved-report?)]
|
||||
[lookup-bug-report (-> number? saved-report?)]
|
||||
[saved-report-lookup (-> saved-report? (apply or/c valid-keys) string?)]
|
||||
[saved-report-id (-> saved-report? number?)]
|
||||
[save-bug-report (-> number?
|
||||
#:severity (apply or/c bug-severities)
|
||||
#:class (apply or/c (map car bug-classes))
|
||||
#:subject string?
|
||||
#:description string?
|
||||
#:how-to-repeat string?
|
||||
void?)]
|
||||
[unsave-bug-report (-> number? void?)]
|
||||
[saved-bug-report-titles/ids (-> (listof brinfo?))]
|
||||
[discard-all-except (-> (-> number? boolean?) void?)])
|
||||
|
|
@ -156,7 +156,7 @@ please adhere to these guidelines:
|
|||
(bug-report-synthesized-information "Indsamlet information") ;; dialog title
|
||||
(bug-report-show-synthesized-info "Vis indsamlet information")
|
||||
(bug-report-submit "Send")
|
||||
(bug-report-submit-menu-item "Send fejlrapport") ;; in Help Menu (drs & help desk)
|
||||
(bug-report-submit-menu-item "Send fejlrapport...") ;; in Help Menu (drs & help desk)
|
||||
(error-sending-bug-report "Fejl under afsendelse af fejlrapport")
|
||||
(error-sending-bug-report-expln "Der opstod en fejl ved afsendelse af fejlrapporten. Hvis din internetforbindelse ellers er velfungerende, besøg venligst:\n\n http://bugs.racket-lang.org/\n\nog send fejlrapporten ved hjælp af vores online fejlrapporteringsside. Vi er kede af besværet.\n\nFejlmeddelelsen er:\n~a")
|
||||
(illegal-bug-report "Ugyldig fejlrapport")
|
||||
|
|
|
|||
|
|
@ -153,12 +153,19 @@ please adhere to these guidelines:
|
|||
(bug-report-field-docs-installed "Docs Installed")
|
||||
(bug-report-field-collections "Collections")
|
||||
(bug-report-field-human-language "Human Language")
|
||||
(bug-report-field-memory-use "Memory Use")
|
||||
(bug-report-field-memory-use "Memory Use")
|
||||
(bug-report-field-version "Version")
|
||||
(bug-report-synthesized-information "Synthesized Information") ;; dialog title
|
||||
(bug-report-show-synthesized-info "Show Synthesized Info")
|
||||
(bug-report-submit "Submit")
|
||||
(bug-report-submit-menu-item "Submit Bug Report") ;; in Help Menu (drs & help desk)
|
||||
(close-and-save-bug-report "Close && Save") ;; button in bug report dialog, next to cancel and bug-report-submit
|
||||
(bug-report-submit-menu-item "Submit Bug Report...") ;; same as above, but used when there are saved bug reports
|
||||
(saved-bug-reports-menu-item "Saved Bug Reports") ;; in Help Menu, submenu title
|
||||
(disacard-all-saved-bug-reports "Discard All Saved Bug Reports") ;; menu item: only shows up when there is more than one saved bug report
|
||||
(no-saved-bug-reports "No bug reports have been saved") ;; an info message that shows up as a disabled menu item when no saved bug reports are around
|
||||
(new-bug-report "New Bug Report") ;; button label the user sees when there are saved bug reports, but the user asks to save another one.
|
||||
(close-and-save "Close and Save") ;; button on the bottom of the bug report form
|
||||
(saved-unsubmitted-bug-reports "Saved, unsubmitted bug reports:") ;; next to previous line in same dialog, followed by list of bug report subjects (as buttons)
|
||||
(error-sending-bug-report "Error Sending Bug Report")
|
||||
(error-sending-bug-report-expln "An error occurred when sending this bug report. If your internet connection is otherwise working fine, please visit:\n\n http://bugs.racket-lang.org/\n\nand submit the bug via our online web-form. Sorry for the difficulties.\n\nThe error message is:\n~a")
|
||||
(illegal-bug-report "Illegal Bug Report")
|
||||
|
|
|
|||
|
|
@ -158,7 +158,7 @@
|
|||
(bug-report-synthesized-information "Information Synthétisée") ;; dialog title
|
||||
(bug-report-show-synthesized-info "Montrer l'information synthétisée")
|
||||
(bug-report-submit "Soumettre")
|
||||
(bug-report-submit-menu-item "Soumettre un rapport de bogue") ;; in Help Menu (drs & help desk)
|
||||
(bug-report-submit-menu-item "Soumettre un rapport de bogue...") ;; in Help Menu (drs & help desk)
|
||||
(error-sending-bug-report "Erreur durant la soumission du rapport de bogue.")
|
||||
(error-sending-bug-report-expln "Une erreur s'est produite pendant la soumission de votre rapport de bogue. Si votre connexion Internet fonctionne correctement, veuillez visiter :\n\n http://bugs.racket-lang.org/\n\net soumettre votre bogue en utilisant notre formulaire web en ligne. Je suis vraiment profondément désolé pour toutes vos difficultés.\n\nLe message d'erreur est :\n~a")
|
||||
(illegal-bug-report "Formulaire de soumission de bogue incomplet.")
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@
|
|||
(bug-report-synthesized-information "Generierte Information") ;; dialog title
|
||||
(bug-report-show-synthesized-info "Generierte Informationen anzeigen") ; (an)zeigen
|
||||
(bug-report-submit "Abschicken")
|
||||
(bug-report-submit-menu-item "Bug-Report abschicken") ;; in Help Menu (drs & help desk)
|
||||
(bug-report-submit-menu-item "Bug-Report abschicken...") ;; in Help Menu (drs & help desk)
|
||||
(error-sending-bug-report "Versendung des Bug-Reports fehlgeschlagen")
|
||||
(error-sending-bug-report-expln "Ein Fehler ist beim Versenden des Bug-Reports aufgetreten. Falls Ihre Internet-Verbindung eigentlich funktioniert, besuchen Sie bitte:\n\n http://bugs.racket-lang.org/ \n\nund teilen Sie uns den Bug mit unserem Online-Formular mit. Wir bitten um Ihr Verständnis.\n\nDie Fehlermeldung lautet:\n~a")
|
||||
(illegal-bug-report "Ungültiger Bug-Report")
|
||||
|
|
|
|||
|
|
@ -157,7 +157,7 @@ please adhere to these guidelines:
|
|||
(bug-report-synthesized-information "詳細情報") ;; dialog title
|
||||
(bug-report-show-synthesized-info "詳細情報の表示")
|
||||
(bug-report-submit "送信")
|
||||
(bug-report-submit-menu-item "バグ報告の送信") ;; in Help Menu (drs & help desk)
|
||||
(bug-report-submit-menu-item "バグ報告の送信...") ;; in Help Menu (drs & help desk)
|
||||
(error-sending-bug-report "バグ報告の送信エラー")
|
||||
(error-sending-bug-report-expln "バグ報告の送信中にエラーが発生しました。もし、インターネット接続が正常であるなら、\n\n http://bugs.racket-lang.org/\n\nを開いて、オンラインのウェブフォームからバグ報告を行ってください。お手間をかけて申し訳ありません。\n\nエラーメッセージ:\n~a")
|
||||
(illegal-bug-report "バグ報告が正しく入力されていません")
|
||||
|
|
|
|||
|
|
@ -76,7 +76,7 @@
|
|||
(bug-report-synthesized-information "세부 정보") ;; dialog title
|
||||
(bug-report-show-synthesized-info "세부 정보 보기")
|
||||
(bug-report-submit "제출")
|
||||
(bug-report-submit-menu-item "오류 보고 제출") ;; in Help Menu (drs & help desk)
|
||||
(bug-report-submit-menu-item "오류 보고 제출...") ;; in Help Menu (drs & help desk)
|
||||
(error-sending-bug-report "오류 보고 보내기 오류")
|
||||
(error-sending-bug-report-expln "오류 보고 도중에 오류가 발생했습니다. 다른 인터넷 연결이 원활하다면, 다음 사이트를 방문하여:\n\n http://bugs.racket-lang.org/\n\n 오류 보고를 온라인 형식으로
|
||||
제출하여 주십시오. 불편을 드려 죄송합니다.\n\n 오류 메세지는 다음과 같습니다 :\n~a")
|
||||
|
|
|
|||
|
|
@ -158,7 +158,7 @@ please adhere to these guidelines:
|
|||
(bug-report-synthesized-information "Informação Gerada") ;; dialog title
|
||||
(bug-report-show-synthesized-info "Mostrar Informação Gerada")
|
||||
(bug-report-submit "Enviar")
|
||||
(bug-report-submit-menu-item "Enviar relatório de erro") ;; in Help Menu (drs & help desk)
|
||||
(bug-report-submit-menu-item "Enviar relatório de erro...") ;; in Help Menu (drs & help desk)
|
||||
(error-sending-bug-report "Erro a Enviar relatório de erro")
|
||||
(error-sending-bug-report-expln "Um erro ocorreu enquanto o relatório de erro estava a ser enviado. Se a sua ligação à internet está a funcionar correctamente, por favor visite:\n\n http://bugs.racket-lang.org/\n\ne envie o erro através do nosso formulário online. Pedimos desculpa pelo incómodo.\n\nA mensagem de erro é:\n~a")
|
||||
(illegal-bug-report "Relatório de Erro Ilegal")
|
||||
|
|
|
|||
|
|
@ -158,7 +158,7 @@ please adhere to these guidelines:
|
|||
(bug-report-synthesized-information "Собранные данные") ;; dialog title
|
||||
(bug-report-show-synthesized-info "Показать собранные данные")
|
||||
(bug-report-submit "Отправить")
|
||||
(bug-report-submit-menu-item "Отправить отчет об ошибке") ;; in Help Menu (drs & help desk)
|
||||
(bug-report-submit-menu-item "Отправить отчет об ошибке...") ;; in Help Menu (drs & help desk)
|
||||
(error-sending-bug-report "Сбой при отправке отчета об ошибке")
|
||||
(error-sending-bug-report-expln "При отправке отчета об ошибке произошел сбой. При наличии работающего подключения к Internet посетите сайт:\n\n http://bugs.racket-lang.org/\n\nи отправьте отчет об ошибке через Web-форму на нем. Извините за неудобства.\n\nСообщение об ошибке:\n~a")
|
||||
(illegal-bug-report "Некорректный отчет об ошибке")
|
||||
|
|
|
|||
|
|
@ -85,7 +85,7 @@
|
|||
(bug-report-synthesized-information "综合信息") ;; dialog title
|
||||
(bug-report-show-synthesized-info "显示综合信息")
|
||||
(bug-report-submit "提交")
|
||||
(bug-report-submit-menu-item "提交程序错误报告") ;; in Help Menu (drs & help desk)
|
||||
(bug-report-submit-menu-item "提交程序错误报告...") ;; in Help Menu (drs & help desk)
|
||||
(error-sending-bug-report "程序错误报告传输出错")
|
||||
(error-sending-bug-report-expln "在传输程序错误报告的过程中出现了错误。如果你能够正常浏览网络，请访问：\n\n http://bugs.racket-lang.org/\n\n使用网页上的表单提交程序错误报告。对于由此产生的不便，我们表示抱歉。\n\n传输错误详情：\n~a")
|
||||
(illegal-bug-report "非法的程序错误报告")
|
||||
|
|
|
|||
|
|
@ -65,7 +65,7 @@
|
|||
(bug-report-synthesized-information "Información sintetizada") ;; dialog title
|
||||
(bug-report-show-synthesized-info "Muestra información resumida")
|
||||
(bug-report-submit "Enviar")
|
||||
(bug-report-submit-menu-item "Enviar reporte de problemas") ;; in Help Menu (drs & help desk)
|
||||
(bug-report-submit-menu-item "Enviar reporte de problemas...") ;; in Help Menu (drs & help desk)
|
||||
(error-sending-bug-report "Error al enviar el reporte de problemas")
|
||||
(error-sending-bug-report-expln "Un error ocurrió mientras enviaba éste reporte de problemas. Si tu conexión a Internet está funcionando bien, por favor visita:\n\n http://bugs.racket-lang.org/\n\ny envía el reporte de problemas por medio de la forma de web en esea página de WEB. Sentimos mucho las molestias que esto te ocasiona.\n\nEl mensaje de error es:\n~a")
|
||||
(illegal-bug-report "Reporte de problemas ilegal")
|
||||
|
|
|
|||
|
|
@ -84,7 +84,7 @@
|
|||
(bug-report-synthesized-information "综合信息") ;; dialog title
|
||||
(bug-report-show-synthesized-info "显示综合信息")
|
||||
(bug-report-submit "提交")
|
||||
(bug-report-submit-menu-item "提交程序错误报告") ;; in Help Menu (drs & help desk)
|
||||
(bug-report-submit-menu-item "提交程序错误报告...") ;; in Help Menu (drs & help desk)
|
||||
(error-sending-bug-report "程序错误报告传输出错")
|
||||
(error-sending-bug-report-expln "在传输程序错误报告的过程中出现了错误。如果你能够正常浏览网络，请访问：\n\n http://bugs.racket-lang.org/\n\n使用网页上的表单提交程序错误报告。对于由此产生的不便，我们表示抱歉。\n\n传输错误详情：\n~a")
|
||||
(illegal-bug-report "非法的程序错误报告")
|
||||
|
|
|
|||
|
|
@ -158,7 +158,7 @@ please adhere to these guidelines:
|
|||
(bug-report-synthesized-information "Зібрані дані") ;; dialog title
|
||||
(bug-report-show-synthesized-info "Показати зібрані дані")
|
||||
(bug-report-submit "Відправити")
|
||||
(bug-report-submit-menu-item "Відправити звіт про помилку") ;; in Help Menu (drs & help desk)
|
||||
(bug-report-submit-menu-item "Відправити звіт про помилку...") ;; in Help Menu (drs & help desk)
|
||||
(error-sending-bug-report "Збій при відправці звіту про помилку")
|
||||
(error-sending-bug-report-expln "При відправці звіту про помилку відбувся збій. При наявності підключення до Internet відвідайте сайт:\n\n http://bugs.racket-lang.org/\n\nі відправте звіт про помилку через Web-форму на ньому. Вибачте за незручності.\n\nПовідомлення про помилку:\n~a")
|
||||
(illegal-bug-report "Некоректний звіт про помилку")
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user