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

9
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) (super on-paint before dc left-margin top-margin right-margin bottom-margin dx dy draw-caret)
(when before (when before
(let-values ([(view-x view-y view-width view-height) (let-values ([(view-x view-y view-width view-height)
(let ([admin (get-admin)])
(if admin
(let ([b1 (box 0)] (let ([b1 (box 0)]
[b2 (box 0)] [b2 (box 0)]
[b3 (box 0)] [b3 (box 0)]
[b4 (box 0)]) [b4 (box 0)])
(send (get-admin) get-view b1 b2 b3 b4) (send admin get-view b1 b2 b3 b4)
(values (unbox b1) (values (unbox b1)
(unbox b2) (unbox b2)
(unbox b3) (unbox b3)
(unbox b4)))]) (unbox b4)))
(values left-margin top-margin right-margin bottom-margin)))])
(let* ([old-pen (send dc get-pen)] (let* ([old-pen (send dc get-pen)]
[old-brush (send dc get-brush)] [old-brush (send dc get-brush)]
[old-smoothing (send dc get-smoothing)] [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)] [top (rectangle-top rectangle)]
[right (if (number? (rectangle-right rectangle)) [right (if (number? (rectangle-right rectangle))
(rectangle-right rectangle) (rectangle-right rectangle)
(+ view-x view-width))] view-x)]
[bottom (rectangle-bottom rectangle)] [bottom (rectangle-bottom rectangle)]
[width (max 0 (- right left))] [width (max 0 (- right left))]
[height (max 0 (- bottom top))]) [height (max 0 (- bottom top))])

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

@ -161,3 +161,40 @@
#:exists 'truncate) #:exists 'truncate)
(send t load-file) (send t load-file)
(length (send t get-highlighted-ranges))))))) (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))))