From ec122a785ad01920eb851c4a2fdad9240b7f3ef0 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 1 Dec 2010 15:48:43 -0700
Subject: [PATCH] use dots for 'password style text-field%

---
 collects/mred/private/wxtextfield.rkt | 83 +++++++++++++++++++++------
 1 file changed, 66 insertions(+), 17 deletions(-)

diff --git a/collects/mred/private/wxtextfield.rkt b/collects/mred/private/wxtextfield.rkt
index e87ae2c890..6f4c7f391f 100644
--- a/collects/mred/private/wxtextfield.rkt
+++ b/collects/mred/private/wxtextfield.rkt
@@ -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))