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

PR 10591

Browse Source 
svn: r16897
This commit is contained in:
Robby Findler 2009-11-19 20:29:36 +00:00
parent acba624431
commit 8d96441673
2 changed files with 50 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/framework/private/text.ss
View File

@ -451,15 +451,18 @@ WARNING: printf is rebound in the body of the unit to always
(super on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
(when before
(let-values ([(view-x view-y view-width view-height)
(let ([b1 (box 0)]
[b2 (box 0)]
[b3 (box 0)]
[b4 (box 0)])
(send (get-admin) get-view b1 b2 b3 b4)
(values (unbox b1)
(unbox b2)
(unbox b3)
(unbox b4)))])
(let ([admin (get-admin)])
(if admin
(let ([b1 (box 0)]
[b2 (box 0)]
[b3 (box 0)]
[b4 (box 0)])
(send admin get-view b1 b2 b3 b4)
(values (unbox b1)
(unbox b2)
(unbox b3)
(unbox b4)))
(values left-margin top-margin right-margin bottom-margin)))])
(let* ([old-pen (send dc get-pen)]
[old-brush (send dc get-brush)]
[old-smoothing (send dc get-smoothing)]
@ -472,7 +475,7 @@ WARNING: printf is rebound in the body of the unit to always
[top (rectangle-top rectangle)]
[right (if (number? (rectangle-right rectangle))
(rectangle-right rectangle)
(+ view-x view-width))]
view-x)]
[bottom (rectangle-bottom rectangle)]
[width (max 0 (- right left))]
[height (max 0 (- bottom top))])

37
collects/tests/framework/text.ss
View File

@ -161,3 +161,40 @@
#:exists 'truncate)
(send t load-file)
(length (send t get-highlighted-ranges)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; print-to-dc
;;
(test
'print-to-dc
(λ (x) (equal? x 'no-error))
(λ ()
(send-sexp-to-mred
'(let* ([t (new text:basic%)]
[bmp (make-object bitmap% 100 40)]
[dc (new bitmap-dc% (bitmap bmp))])
(send t insert "Hello world")
(send dc clear)
(send t print-to-dc dc 1)
'no-error))))
(test
'print-to-dc2
(λ (x) (equal? x 'no-error))
(λ ()
(send-sexp-to-mred
`(let* ([f (new frame% [label ""])]
[t (new text:basic%)]
[ec (new editor-canvas% [parent f] [editor t])]
[bmp (make-object bitmap% 100 40)]
[dc (new bitmap-dc% (bitmap bmp))])
(send t insert "Hello world")
(send t highlight-range 2 5 "orange")
(send f reflow-container)
(send dc clear)
(send t print-to-dc dc 1)
'no-error))))