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

restore doc & page checking for `post-script-dc%' et al.

Browse Source 
and also fix up wiring of `printer-dc%' in `editor<%>' so
 that `is-a?' tests works as expected
This commit is contained in:
Matthew Flatt 2011-01-14 20:07:44 -07:00
parent 73d71d7597
commit a9dd80110a
21 changed files with 177 additions and 171 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/mred/private/filedialog.rkt
View File

@ -4,7 +4,8 @@
mzlib/list
(prefix wx: "kernel.ss")
(prefix wx: racket/snip)
(prefix wx: "wxme/cycle.ss")
(rename "wxme/cycle.ss" wx:set-editor-get-file! set-editor-get-file!)
(rename "wxme/cycle.ss" wx:set-editor-put-file! set-editor-put-file!)
"lock.ss"
"wx.ss"
"cycle.ss"

135
collects/mred/private/gdi.rkt
View File

@ -2,7 +2,9 @@
(require mzlib/class
mzlib/class100
mzlib/list
racket/draw/private/page-dc
(prefix wx: "kernel.ss")
(rename "wxme/cycle.ss" wx:set-printer-dc%! set-printer-dc%!)
"lock.ss"
"check.ss"
"wx.ss"
@ -46,123 +48,24 @@
(check-instance 'unregister-collecting-blit canvas% 'canvas% #f canvas)
(wx:unregister-collecting-blit (mred->wx canvas))))
(define-syntax check-page-active
(syntax-rules ()
[(_ check-page-status (id . args) ...) (begin (check-one-page-active check-page-status id args) ...)]))
(define-syntax check-one-page-active
(syntax-rules ()
[(_ check-page-status id simple ... (arg ... [opt ...]))
(check-one-page-active
check-page-status id
simple ...
(arg ...)
(arg ... opt ...))]
[(_ check-page-status id (arg ...) ...)
(define/override id
(case-lambda
[(arg ...) (check-page-status 'id) (super id arg ...)]
...))]))
(define-local-member-name multiple-pages-ok?)
(define (doc+page-check-mixin % class-name)
(class %
(define status #f)
(define did-one-page? #f)
(define/public (multiple-pages-ok?) #t)
(define/override (start-doc s)
(when status
(raise-mismatch-error (who->name (list 'method class-name 'start-doc))
(case status
[(done)
"document has already been ended: "]
[else
"document has already been started: "])
this))
(set! status 'doc)
(super start-doc s))
(define/override (end-doc)
(unless (eq? status 'doc)
(raise-mismatch-error (who->name (list 'method class-name 'end-doc))
(case status
[(page)
"current page has not been ended: "]
[(done)
"document is already ended: "]
[(#f)
"document is not started: "])
this))
(set! status 'done)
(super end-doc))
(define/override (start-page)
(unless (eq? status 'doc)
(raise-mismatch-error (who->name (list 'method class-name 'start-page))
(if (eq? status 'page)
"current page has not been ended: "
"document is not started (use the `start-doc' method): ")
this))
(when did-one-page?
(unless (multiple-pages-ok?)
(raise-mismatch-error (who->name (list 'method class-name 'start-page))
"cannot create multiple pages for EPS output: "
this)))
(set! status 'page)
(set! did-one-page? #t)
(super start-page))
(define/override (end-page)
(unless (eq? status 'page)
(raise-mismatch-error (who->name (list 'method class-name 'end-page))
"no page is currently started: "
this))
(set! status 'doc)
(super end-page))
(define/private (check-page-status method-name)
(unless (eq? status 'page)
(raise-mismatch-error (who->name (list 'method class-name method-name))
"no page is currently started (use `start-doc' and `start-page' before drawing): "
this)))
(check-page-active
check-page-status
(draw-bitmap source dest-x dest-y [style [color [mask]]])
(draw-bitmap-section source dest-x dest-y src-x src-y src-width src-height [style [color [mask]]])
(set-text-foreground c)
(set-text-background c)
(set-brush b/c [style])
(set-pen p/c [width style])
(set-font f)
(set-background c)
(set-clipping-region r)
(set-clipping-rect x y w h)
(draw-polygon pts [x [y [fill]]])
(draw-lines pts [x [y]])
(draw-path path [x [y [fill]]])
(draw-ellipse x y w h)
(draw-arc x y w h s e)
(draw-text txt x y [combine? [offset [angle]]])
(draw-spline x1 y1 x2 y2 x3 y3)
(draw-rounded-rectangle x y w h [r])
(draw-rectangle x y w h)
(draw-point x y)
(draw-line x1 y1 x2 y2)
(clear))
(super-new)))
(define printer-dc%
(class100 (doc+page-check-mixin wx:printer-dc% 'printer-dc%) ([parent #f])
(sequence
(check-top-level-parent/false '(constructor printer-dc) parent)
(as-entry
(lambda ()
(let ([p (and parent (mred->wx parent))])
(as-exit (lambda () (super-init p)))))))))
(class (doc+page-check-mixin (class wx:printer-dc%
(define/public (multiple-pages-ok?) #t)
(super-new))
'printer-dc%)
(init [parent #f])
(let ([prim? (or (parent . is-a? . wx:frame%)
(parent . is-a? . wx:dialog%))])
(unless prim?
(check-top-level-parent/false '(constructor printer-dc) parent))
(as-entry
(lambda ()
(let ([p (if prim?
parent
(and parent (mred->wx parent)))])
(as-exit (lambda () (super-new [parent p])))))))))
(wx:set-printer-dc%! printer-dc%)
(define get-window-text-extent
(case-lambda

2
collects/mred/private/mrpopup.rkt
View File

@ -3,7 +3,7 @@
mzlib/class100
mzlib/list
(prefix wx: "kernel.ss")
(prefix wx: "wxme/cycle.ss")
(rename "wxme/cycle.ss" wx:set-popup-menu%! set-popup-menu%!)
"lock.ss"
"const.ss"
"helper.ss"

1
collects/mred/private/snipfile.rkt
View File

@ -4,7 +4,6 @@
syntax/moddep
(prefix-in wx: "kernel.ss")
(prefix-in wx: racket/snip)
(prefix-in wx: "wxme/cycle.ss")
"check.ss"
"editor.ss")

1
collects/mred/private/wx/cocoa/platform.rkt
View File

@ -67,7 +67,6 @@
get-control-font-size
get-control-font-size-in-pixels?
get-double-click-time
run-printout
file-creator-and-type
location->window
shortcut-visible-in-label?

4
collects/mred/private/wx/cocoa/procs.rkt
View File

@ -14,7 +14,6 @@
"dc.rkt"
"bitmap.rkt"
"printer-dc.rkt"
"../common/printer.rkt"
"menu-bar.rkt"
"agl.rkt"
"sound.rkt"
@ -35,7 +34,6 @@
register-collecting-blit
unregister-collecting-blit
shortcut-visible-in-label?
run-printout
get-double-click-time
get-control-font-face
get-control-font-size
@ -79,8 +77,6 @@
(send canvas unregister-collecting-blits))
(define (shortcut-visible-in-label? [x #f]) #f)
(define run-printout (make-run-printout printer-dc%))
(define (get-double-click-time)
500)
(define (get-control-font-face) "Lucida Grande")

25
collects/mred/private/wx/common/printer.rkt
View File

@ -1,25 +0,0 @@
#lang racket/base
(require racket/class)
(provide (protect-out make-run-printout))
(define ((make-run-printout printer-dc%)
parent
interactive? ; currently ignored
fit-to-page? ; ignored
begin-doc-proc
has-page?-proc
print-page-proc
end-doc-proc)
(let ([dc (make-object printer-dc% parent)])
(send dc start-doc "printing")
(begin-doc-proc dc)
(let loop ([i 1])
(when (has-page?-proc dc i)
(begin
(send dc start-page)
(print-page-proc dc i)
(send dc end-page)
(loop (add1 i)))))
(end-doc-proc)
(send dc end-doc)))

1
collects/mred/private/wx/gtk/platform.rkt
View File

@ -68,7 +68,6 @@
get-control-font-size
get-control-font-size-in-pixels?
get-double-click-time
run-printout
file-creator-and-type
location->window
shortcut-visible-in-label?

4
collects/mred/private/wx/gtk/procs.rkt
View File

@ -16,7 +16,6 @@
"queue.rkt"
"printer-dc.rkt"
"gl-context.rkt"
"../common/printer.rkt"
"../common/default-procs.rkt"
"../common/handlers.rkt")
@ -30,7 +29,6 @@
register-collecting-blit
unregister-collecting-blit
shortcut-visible-in-label?
run-printout
get-double-click-time
get-control-font-face
get-control-font-size
@ -82,8 +80,6 @@
(send canvas unregister-collecting-blits))
(define (shortcut-visible-in-label? [mbar? #f]) #t)
(define run-printout (make-run-printout printer-dc%))
(define _GtkSettings (_cpointer 'GtkSettings))
(define-gtk gtk_settings_get_default (_fun -> _GtkSettings))
(define-gobj g_object_get/int (_fun _GtkSettings _string (r : (_ptr o _int)) (_pointer = #f)

1
collects/mred/private/wx/platform.rkt
View File

@ -54,7 +54,6 @@
get-control-font-size
get-control-font-size-in-pixels?
get-double-click-time
run-printout
file-creator-and-type
location->window
shortcut-visible-in-label?

1
collects/mred/private/wx/win32/platform.rkt
View File

@ -68,7 +68,6 @@
get-control-font-size
get-control-font-size-in-pixels?
get-double-click-time
run-printout
file-creator-and-type
location->window
shortcut-visible-in-label?

4
collects/mred/private/wx/win32/procs.rkt
View File

@ -11,7 +11,6 @@
"window.rkt"
"dc.rkt"
"printer-dc.rkt"
"../common/printer.rkt"
(except-in "../common/default-procs.rkt"
get-panel-background)
"filedialog.rkt"
@ -29,7 +28,6 @@
register-collecting-blit
unregister-collecting-blit
shortcut-visible-in-label?
run-printout
get-double-click-time
get-control-font-face
get-control-font-size
@ -80,8 +78,6 @@
(send canvas unregister-collecting-blits))
(define (shortcut-visible-in-label? [? #f]) #t)
(define run-printout (make-run-printout printer-dc%))
(define (get-double-click-time) 500)
(define (get-control-font-face) (get-theme-font-face))
(define (get-control-font-size) (get-theme-font-size))

1
collects/mred/private/wxme/cycle.rkt
View File

@ -24,4 +24,5 @@
(decl popup-menu% set-popup-menu%!)
(decl printer-dc% set-printer-dc%!)

22
collects/mred/private/wxme/editor.rkt
View File

@ -14,6 +14,7 @@
"keymap.ss"
"editor-data.rkt"
(only-in "cycle.ss"
printer-dc%
text%
pasteboard%
editor-snip%
@ -736,6 +737,27 @@
(define/public (do-end-print) (void))
(define/public (do-has-print-page?) (void))
(define/private (run-printout
parent
interactive? ; currently ignored
fit-to-page? ; ignored
begin-doc-proc
has-page?-proc
print-page-proc
end-doc-proc)
(let ([dc (make-object printer-dc% parent)])
(send dc start-doc "printing")
(begin-doc-proc dc)
(let loop ([i 1])
(when (has-page?-proc dc i)
(begin
(send dc start-page)
(print-page-proc dc i)
(send dc end-page)
(loop (add1 i)))))
(end-doc-proc)
(send dc end-doc)))
(def/public (print [bool? [interactive? #t]]
[bool? [fit-to-page? #t]]
[(symbol-in standard postscript) [output-mode 'standard]]

4
collects/mred/private/wxme/pasteboard.rkt
View File

@ -13,7 +13,9 @@
racket/snip/private/snip-flags
"standard-snip-admin.rkt"
"keymap.ss"
(only-in "cycle.ss" set-pasteboard%!)
(only-in "cycle.ss"
printer-dc%
set-pasteboard%!)
"wordbreak.ss"
"stream.ss"
"wx.ss")

4
collects/mred/private/wxme/text.rkt
View File

@ -15,7 +15,9 @@
racket/snip/private/snip-flags
"standard-snip-admin.rkt"
"keymap.ss"
(only-in "cycle.ss" set-text%!)
(only-in "cycle.ss"
printer-dc%
set-text%!)
"wordbreak.ss"
"stream.ss"
"wx.ss")

2
collects/mred/private/wxme/wx.rkt
View File

@ -27,7 +27,6 @@
bitmap%
dc<%>
post-script-dc%
printer-dc%
current-eventspace
clipboard-client%
clipboard<%>
@ -37,7 +36,6 @@
begin-busy-cursor
end-busy-cursor
hide-cursor
run-printout
current-ps-setup
get-highlight-background-color
get-highlight-text-color)

109
collects/racket/draw/private/page-dc.rkt Normal file
View File

@ -0,0 +1,109 @@
#lang racket/base
(require racket/class
"syntax.rkt")
(provide doc+page-check-mixin
multiple-pages-ok?)
(define-local-member-name multiple-pages-ok?)
(define-syntax check-page-active
(syntax-rules ()
[(_ check-page-status (id . args) ...) (begin (check-one-page-active check-page-status id args) ...)]))
(define-syntax check-one-page-active
(syntax-rules ()
[(_ check-page-status id simple ... (arg ... [opt ...]))
(check-one-page-active
check-page-status id
simple ...
(arg ...)
(arg ... opt ...))]
[(_ check-page-status id (arg ...) ...)
(define/override id
(case-lambda
[(arg ...) (check-page-status 'id) (super id arg ...)]
...))]))
(define (doc+page-check-mixin % class-name)
(class %
(inherit multiple-pages-ok?)
(define status #f)
(define did-one-page? #f)
(define/override (start-doc s)
(when status
(raise-mismatch-error (method-name class-name 'start-doc)
(case status
[(done)
"document has already been ended: "]
[else
"document has already been started: "])
this))
(set! status 'doc)
(super start-doc s))
(define/override (end-doc)
(unless (eq? status 'doc)
(raise-mismatch-error (method-name class-name 'end-doc)
(case status
[(page)
"current page has not been ended: "]
[(done)
"document is already ended: "]
[(#f)
"document is not started: "])
this))
(set! status 'done)
(super end-doc))
(define/override (start-page)
(unless (eq? status 'doc)
(raise-mismatch-error (method-name class-name 'start-page)
(if (eq? status 'page)
"current page has not been ended: "
"document is not started (use the `start-doc' method): ")
this))
(when did-one-page?
(unless (multiple-pages-ok?)
(raise-mismatch-error (method-name class-name 'start-page)
"cannot create multiple pages for encapsulated output: "
this)))
(set! status 'page)
(set! did-one-page? #t)
(super start-page))
(define/override (end-page)
(unless (eq? status 'page)
(raise-mismatch-error (method-name class-name 'end-page)
"no page is currently started: "
this))
(set! status 'doc)
(super end-page))
(define/private (check-page-status the-method-name)
(unless (eq? status 'page)
(raise-mismatch-error (method-name class-name the-method-name)
"no page is currently started (use `start-doc' and `start-page' before drawing): "
this)))
(check-page-active
check-page-status
(draw-bitmap source dest-x dest-y [style [color [mask]]])
(draw-bitmap-section source dest-x dest-y src-x src-y src-width src-height [style [color [mask]]])
(draw-polygon pts [x [y [fill]]])
(draw-lines pts [x [y]])
(draw-path path [x [y [fill]]])
(draw-ellipse x y w h)
(draw-arc x y w h s e)
(draw-text txt x y [combine? [offset [angle]]])
(draw-spline x1 y1 x2 y2 x3 y3)
(draw-rounded-rectangle x y w h [r])
(draw-rectangle x y w h)
(draw-point x y)
(draw-line x1 y1 x2 y2)
(clear)
(erase))
(super-new)))

10
collects/racket/draw/private/post-script-dc.rkt
View File

@ -11,6 +11,7 @@
"font.ss"
"local.ss"
"ps-setup.ss"
"page-dc.rkt"
"write-bytes.rkt")
(provide post-script-dc%
@ -176,9 +177,14 @@
(define/override (can-mask-bitmap?)
#f)
(define is-eps? (and as-eps #t))
(define/public (multiple-pages-ok?) (not is-eps?))
(super-new)))
(define post-script-dc% (class (dc-mixin (make-dc-backend #f))
(define post-script-dc% (class (doc+page-check-mixin (dc-mixin (make-dc-backend #f))
'post-script-dc%)
(super-new)))
(define pdf-dc% (class (dc-mixin (make-dc-backend #t))
(define pdf-dc% (class (doc+page-check-mixin (dc-mixin (make-dc-backend #t))
'pdf-dc%)
(super-new)))

6
collects/racket/draw/private/svg-dc.rkt
View File

@ -10,6 +10,7 @@
"font.ss"
"local.ss"
"ps-setup.ss"
"page-dc.rkt"
"write-bytes.rkt")
(provide svg-dc%)
@ -80,7 +81,10 @@
(define/override (can-combine-text? sz)
#t)
(define/public (multiple-pages-ok?) #t)
(super-new)))
(define svg-dc% (class (dc-mixin dc-backend%)
(define svg-dc% (class (doc+page-check-mixin (dc-mixin dc-backend%)
'svg-dc%)
(super-new)))

8
collects/scribblings/draw/dc-intf.scrbl
View File

@ -443,7 +443,7 @@ Ends a document, relevant only when drawing to a printer, PostScript,
PDF, or SVG device.
For relevant devices, an exception is raised if
@scheme[end-doc] is called when the document is not started with
@method[dc<%> end-doc] is called when the document is not started with
@method[dc<%> start-doc], when a page is currently started by
@method[dc<%> start-page] and not ended with @method[dc<%> end-page],
or when the document has been ended already.
@ -458,7 +458,7 @@ Ends a single page, relevant only when drawing to a printer,
PostScript, PDF, or SVG device.
For relevant devices, an exception is raised if
@scheme[end-page] is called when a page is not currently started by
@method[dc<%> end-page] is called when a page is not currently started by
@method[dc<%> start-page].}
@ -1071,7 +1071,7 @@ Starts a document, relevant only when drawing to a printer,
@method[dc<%> end-doc] is called.
For relevant devices, an exception is raised if
@scheme[start-doc] has been called already (even if @method[dc<%>
@method[dc<%> start-doc] has been called already (even if @method[dc<%>
end-doc] has been called as well). Furthermore, drawing methods raise
an exception if not called while a page is active as determined by
@method[dc<%> start-doc] and @method[dc<%> start-page].
@ -1085,7 +1085,7 @@ Starts a page, relevant only when drawing to a printer, PostScript,
SVG, or PDF device.
Relevant devices, an exception is raised if
@scheme[start-page] is called when a page is already started, or when
@method[dc<%> start-page] is called when a page is already started, or when
@method[dc<%> start-doc] has not been called, or when @method[dc<%>
end-doc] has been called already. In addition, in the case of
PostScript output, Encapsulated PostScript (EPS) cannot contain