From 956237b041e3981295c3acb797ef17ec7cac804c 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 original commit: a9dd80110a4aa750b60de71bc9432e51f070c6b1 --- 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/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 - 16 files changed, 51 insertions(+), 139 deletions(-) diff --git a/collects/mred/private/filedialog.rkt b/collects/mred/private/filedialog.rkt index 9bef19bb..947dd24c 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 89a847bb..db5f75d6 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 81a75c62..e977ae01 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 017fef68..0c8a2a7d 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 f5e80dad..bd269af6 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 a6caa393..b3c12514 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/gtk/platform.rkt b/collects/mred/private/wx/gtk/platform.rkt index 0abd4fa3..82fff1d7 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 1dc5c903..b64628f2 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 79dcef79..20ed0c37 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 d6652c53..8fd88308 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 c88d403c..04a6bc34 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 05cc6dbd..e55be69c 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 d3a432c4..7d80b25a 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 39933d8c..a0ce97fd 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 081248a6..806056fc 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 759edf5b..65287507 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)