From a9dd80110a4aa750b60de71bc9432e51f070c6b1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 14 Jan 2011 20:07:44 -0700 Subject: [PATCH] restore doc & page checking for `post-script-dc%' et al. and also fix up wiring of `printer-dc%' in `editor<%>' so that `is-a?' tests works as expected --- collects/mred/private/filedialog.rkt | 3 +- collects/mred/private/gdi.rkt | 135 +++--------------- collects/mred/private/mrpopup.rkt | 2 +- collects/mred/private/snipfile.rkt | 1 - collects/mred/private/wx/cocoa/platform.rkt | 1 - collects/mred/private/wx/cocoa/procs.rkt | 4 - collects/mred/private/wx/common/printer.rkt | 25 ---- collects/mred/private/wx/gtk/platform.rkt | 1 - collects/mred/private/wx/gtk/procs.rkt | 4 - collects/mred/private/wx/platform.rkt | 1 - collects/mred/private/wx/win32/platform.rkt | 1 - collects/mred/private/wx/win32/procs.rkt | 4 - collects/mred/private/wxme/cycle.rkt | 1 + collects/mred/private/wxme/editor.rkt | 22 +++ collects/mred/private/wxme/pasteboard.rkt | 4 +- collects/mred/private/wxme/text.rkt | 4 +- collects/mred/private/wxme/wx.rkt | 2 - collects/racket/draw/private/page-dc.rkt | 109 ++++++++++++++ .../racket/draw/private/post-script-dc.rkt | 10 +- collects/racket/draw/private/svg-dc.rkt | 6 +- collects/scribblings/draw/dc-intf.scrbl | 8 +- 21 files changed, 177 insertions(+), 171 deletions(-) delete mode 100644 collects/mred/private/wx/common/printer.rkt create mode 100644 collects/racket/draw/private/page-dc.rkt diff --git a/collects/mred/private/filedialog.rkt b/collects/mred/private/filedialog.rkt index 9bef19bbe4..947dd24cbc 100644 --- a/collects/mred/private/filedialog.rkt +++ b/collects/mred/private/filedialog.rkt @@ -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" diff --git a/collects/mred/private/gdi.rkt b/collects/mred/private/gdi.rkt index 89a847bbcb..db5f75d688 100644 --- a/collects/mred/private/gdi.rkt +++ b/collects/mred/private/gdi.rkt @@ -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 diff --git a/collects/mred/private/mrpopup.rkt b/collects/mred/private/mrpopup.rkt index 81a75c6228..e977ae01e9 100644 --- a/collects/mred/private/mrpopup.rkt +++ b/collects/mred/private/mrpopup.rkt @@ -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" diff --git a/collects/mred/private/snipfile.rkt b/collects/mred/private/snipfile.rkt index 017fef6824..0c8a2a7d54 100644 --- a/collects/mred/private/snipfile.rkt +++ b/collects/mred/private/snipfile.rkt @@ -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") diff --git a/collects/mred/private/wx/cocoa/platform.rkt b/collects/mred/private/wx/cocoa/platform.rkt index f5e80dadc3..bd269af6f6 100644 --- a/collects/mred/private/wx/cocoa/platform.rkt +++ b/collects/mred/private/wx/cocoa/platform.rkt @@ -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? diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index a6caa39307..b3c12514f9 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -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") diff --git a/collects/mred/private/wx/common/printer.rkt b/collects/mred/private/wx/common/printer.rkt deleted file mode 100644 index a421ed376d..0000000000 --- a/collects/mred/private/wx/common/printer.rkt +++ /dev/null @@ -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))) diff --git a/collects/mred/private/wx/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index 0abd4fa342..82fff1d7c0 100644 --- a/collects/mred/private/wx/gtk/platform.rkt +++ b/collects/mred/private/wx/gtk/platform.rkt @@ -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? diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 1dc5c90364..b64628f2cd 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -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) diff --git a/collects/mred/private/wx/platform.rkt b/collects/mred/private/wx/platform.rkt index 79dcef799a..20ed0c37fe 100644 --- a/collects/mred/private/wx/platform.rkt +++ b/collects/mred/private/wx/platform.rkt @@ -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? diff --git a/collects/mred/private/wx/win32/platform.rkt b/collects/mred/private/wx/win32/platform.rkt index d6652c5315..8fd883081d 100644 --- a/collects/mred/private/wx/win32/platform.rkt +++ b/collects/mred/private/wx/win32/platform.rkt @@ -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? diff --git a/collects/mred/private/wx/win32/procs.rkt b/collects/mred/private/wx/win32/procs.rkt index c88d403c4d..04a6bc3499 100644 --- a/collects/mred/private/wx/win32/procs.rkt +++ b/collects/mred/private/wx/win32/procs.rkt @@ -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)) diff --git a/collects/mred/private/wxme/cycle.rkt b/collects/mred/private/wxme/cycle.rkt index 05cc6dbd24..e55be69c6b 100644 --- a/collects/mred/private/wxme/cycle.rkt +++ b/collects/mred/private/wxme/cycle.rkt @@ -24,4 +24,5 @@ (decl popup-menu% set-popup-menu%!) +(decl printer-dc% set-printer-dc%!) diff --git a/collects/mred/private/wxme/editor.rkt b/collects/mred/private/wxme/editor.rkt index d3a432c4cc..7d80b25ab5 100644 --- a/collects/mred/private/wxme/editor.rkt +++ b/collects/mred/private/wxme/editor.rkt @@ -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]] diff --git a/collects/mred/private/wxme/pasteboard.rkt b/collects/mred/private/wxme/pasteboard.rkt index 39933d8c16..a0ce97fd5f 100644 --- a/collects/mred/private/wxme/pasteboard.rkt +++ b/collects/mred/private/wxme/pasteboard.rkt @@ -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") diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index 081248a6d2..806056fc91 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -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") diff --git a/collects/mred/private/wxme/wx.rkt b/collects/mred/private/wxme/wx.rkt index 759edf5bf4..6528750727 100644 --- a/collects/mred/private/wxme/wx.rkt +++ b/collects/mred/private/wxme/wx.rkt @@ -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) diff --git a/collects/racket/draw/private/page-dc.rkt b/collects/racket/draw/private/page-dc.rkt new file mode 100644 index 0000000000..dc8df719a8 --- /dev/null +++ b/collects/racket/draw/private/page-dc.rkt @@ -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))) \ No newline at end of file diff --git a/collects/racket/draw/private/post-script-dc.rkt b/collects/racket/draw/private/post-script-dc.rkt index 6bdede6fba..136f777b40 100644 --- a/collects/racket/draw/private/post-script-dc.rkt +++ b/collects/racket/draw/private/post-script-dc.rkt @@ -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))) diff --git a/collects/racket/draw/private/svg-dc.rkt b/collects/racket/draw/private/svg-dc.rkt index aac6490078..c761f4e34b 100644 --- a/collects/racket/draw/private/svg-dc.rkt +++ b/collects/racket/draw/private/svg-dc.rkt @@ -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))) diff --git a/collects/scribblings/draw/dc-intf.scrbl b/collects/scribblings/draw/dc-intf.scrbl index 260bccea0a..ed2f035f62 100644 --- a/collects/scribblings/draw/dc-intf.scrbl +++ b/collects/scribblings/draw/dc-intf.scrbl @@ -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