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

use dots for 'password style text-field%

Browse Source
This commit is contained in:
Matthew Flatt 2010-12-01 15:48:43 -07:00
parent 93126d1546
commit ec122a785a
1 changed files with 66 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

83
collects/mred/private/wxtextfield.rkt
View File

@ -1,9 +1,10 @@
(module wxtextfield mzscheme
(module wxtextfield racket/base
(require mzlib/class
mzlib/class100
(prefix wx: "kernel.ss")
(prefix wx: "wxme/text.ss")
(prefix wx: "wxme/editor-canvas.ss")
(prefix-in wx: "kernel.ss")
(prefix-in wx: "wxme/text.ss")
(prefix-in wx: "wxme/snip.ss")
(prefix-in wx: "wxme/editor-canvas.ss")
"lock.ss"
"const.ss"
"check.ss"
@ -17,14 +18,63 @@
"editor.ss"
"mrpopup.ss")
(provide (protect wx-text-field%))
(provide (protect-out wx-text-field%))
(define no-pen (send wx:the-pen-list find-or-create-pen "white" 1 'transparent))
(define black-brush (send wx:the-brush-list find-or-create-brush "black" 'solid))
(define password-string-snip%
(class wx:string-snip%
(inherit get-count
get-style
get-text)
(super-new)
(define delta 2)
(define (get-size)
(max 4 (send (send (get-style) get-font) get-point-size)))
(define/override (get-extent dc x y [w #f] [h #f] [descent #f] [space #f] [lspace #f] [rspace #f])
(let ([s (get-size)])
(when w (set-box! w (* s (get-count))))
(when h (set-box! h (+ s 2.0)))
(when descent (set-box! descent 1.0))
(when space (set-box! space 1.0))
(when lspace (set-box! lspace 0.0))
(when rspace (set-box! rspace 0.0))))
(define/override (partial-offset dc x y pos)
(let ([s (get-size)])
(* s pos)))
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(let ([s (get-size)]
[b (send dc get-brush)]
[p (send dc get-pen)]
[m (send dc get-smoothing)])
(send dc set-pen no-pen)
(send dc set-brush black-brush)
(send dc set-smoothing 'aligned)
(for/fold ([x x]) ([i (in-range (get-count))])
(send dc draw-ellipse (+ x delta) (+ y delta 1) (- s delta delta) (- s delta delta))
(+ x s))
(send dc set-pen p)
(send dc set-brush b)
(send dc set-smoothing m)))
(define/override (split pos first second)
(let ([a (new password-string-snip%)]
[b (new password-string-snip%)]
[c (get-count)])
(send a insert (get-text 0 pos) pos)
(send b insert (get-text pos c) (- c pos))
(set-box! first a)
(set-box! second b)))))
(define text-field-text%
(class100 text% (cb ret-cb control set-cb-mgrs! record-text)
(class100 text% (cb ret-cb control set-cb-mgrs! record-text pw?)
(rename [super-on-char on-char])
(inherit get-text last-position set-max-undo-history get-flattened-text)
(private-field
[return-cb ret-cb])
[return-cb ret-cb]
[password? pw?])
(private-field
[block-callback 1]
[callback
@ -42,7 +92,12 @@
(unless (and (or (eq? c #\return) (eq? c #\newline))
return-cb
(return-cb (lambda () (callback 'text-field-enter) #t)))
(as-exit (lambda () (super-on-char e)))))))])
(as-exit (lambda () (super-on-char e)))))))]
[on-new-string-snip
(lambda ()
(if password?
(new password-string-snip%)
(super on-new-string-snip)))])
(augment
[after-insert
(lambda args
@ -91,7 +146,8 @@
(set! without-callback wc)
(set! callback-ready cr))
(lambda (t)
(send c set-combo-text t)))])
(send c set-combo-text t))
(memq 'password style))])
(sequence
(as-exit
(lambda ()
@ -202,14 +258,7 @@
(send e auto-wrap (and multi? (not (memq 'hscroll style))))
(let ([f font]
[s (send (send e get-style-list) find-named-style "Standard")])
(send s set-delta (let ([d (font->delta f)])
(if (memq 'password style)
(begin
(send d set-face #f)
(send d set-family 'modern)
(send d set-delta-foreground "darkgray")
(send d set-delta-background "darkgray"))
d))))
(send s set-delta (font->delta f)))
(send c set-editor e)
(send c set-line-count (if multi? 3 1))
(unless multi? (send c set-single-line))