suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

racket/gui: add 'disallow-invalid style to `get-text-from-user'

Browse Source
This commit is contained in:
Matthew Flatt 2013-08-20 14:32:53 -06:00
parent b24eb311dd
commit 0ecd04787a
2 changed files with 20 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
pkgs/gui-pkgs/gui-doc/scribblings/gui/dialog-funcs.scrbl
View File

@ -391,7 +391,7 @@ Like @racket[message-box/custom], except that
[message (or/c label-string? #f)]
[parent (or/c (is-a?/c frame%) (is-a?/c dialog%) #f) #f]
[init-val string? ""]
[style (listof 'password) null]
[style (listof (or/c 'password 'disallow-invalid)) null]
[#:validate validate (-> string? boolean?)]
[#:dialog-mixin dialog-mixin (make-mixin-contract dialog%) values])
(or/c string? #f)]{
@ -410,8 +410,10 @@ If @racket[style] includes @racket['password], the dialog's text field
of the actual character.
The @racket[validate] function is called each time the text field changed,
with the contents of the text field. If it returns @racket[#t], the background
of the text is colored pink.
with the contents of the text field. If it returns @racket[#f], the background
of the text is colored pink. If @racket['disallow-invalid] is included in
@racket[style], the @onscreen{Ok} button is disabled whenever the text
background is pink.
The @racket[dialog-mixin] argument is applied to the class that implements the dialog
before the dialog is created.

22
pkgs/gui-pkgs/gui-lib/mred/private/moredialogs.rkt
View File

@ -195,7 +195,7 @@
(check-label-string/false 'get-text-from-user message)
(check-top-level-parent/false 'get-text-from-user parent)
(check-string 'get-text-from-user init-val)
(check-style 'get-text-from-user #f '(password) style)
(check-style 'get-text-from-user #f '(password disallow-invalid) style)
(define f (make-object (dialog-mixin dialog%) title parent box-width))
(define ok? #f)
(define (done ?) (set! ok? ?) (send f show #f))
@ -208,22 +208,30 @@
(done #t)]
[else (do-validation)]))]
[init-value init-val]
[style (list* 'single 'vertical-label style)]))
[style (list* 'single 'vertical-label
(if (memq 'password style)
'(password)
'()))]))
(define default-background (send t get-field-background))
(define (do-validation)
(define valid? (validate (send t get-value)))
(send t set-field-background
(if (validate (send t get-value))
(if valid?
default-background
(send wx:the-color-database find-color "pink"))))
(send wx:the-color-database find-color "pink")))
(when (memq 'disallow-invalid style)
(send ok-button enable valid?)))
(define p (make-object horizontal-pane% f))
(send p set-alignment 'right 'center)
(send f stretchable-height #f)
(ok-cancel
(lambda () (make-object button% "OK" p (λ (b e) (done #t)) '(border)))
(lambda () (make-object button% "Cancel" p (λ (b e) (done #f)))))
(define-values (ok-button cancel-button)
(ok-cancel
(lambda () (make-object button% "OK" p (λ (b e) (done #t)) '(border)))
(lambda () (make-object button% "Cancel" p (λ (b e) (done #f))))))
(send (send t get-editor) select-all)
(send t focus)
(send f center)
(do-validation)
(send f show #t)
(and ok? (send t get-value)))