From 84af79f51dd7f0ece31fcacbe4d4671f95cba19b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 14 Oct 2010 21:00:22 -0600 Subject: [PATCH] gtk: printer-dc% original commit: 5e1c4ae1f8d647d98d57888e53a016d962825148 --- collects/mred/private/wx/cocoa/printer-dc.rkt | 20 +- collects/mred/private/wx/gtk/printer-dc.rkt | 232 +++++++++++++++++- collects/mred/private/wx/gtk/procs.rkt | 9 +- collects/mred/private/wxme/editor.rkt | 4 +- 4 files changed, 244 insertions(+), 21 deletions(-) diff --git a/collects/mred/private/wx/cocoa/printer-dc.rkt b/collects/mred/private/wx/cocoa/printer-dc.rkt index b56a5aec..854a5f27 100644 --- a/collects/mred/private/wx/cocoa/printer-dc.rkt +++ b/collects/mred/private/wx/cocoa/printer-dc.rkt @@ -67,6 +67,8 @@ (send pss get-scaling x y) (unbox y)))) +(define NSOkButton 1) + (define (show-print-setup parent) (let* ([pss (current-ps-setup)] [print-info (let ([pi (send pss get-native)]) @@ -75,13 +77,17 @@ (send pss set-native pi make-print-info) pi)))]) (install-pss-to-print-info pss print-info) - (tell (tell NSPageLayout pageLayout) runModalWithPrintInfo: print-info) - (let ([o (tell #:type _int print-info orientation)]) - (send pss set-orientation (if (= o NSLandscapeOrientation) - 'landscape - 'portrait))) - (let ([s (tell #:type _CGFloat print-info scalingFactor)]) - (send pss set-scaling s s)))) + (if (= (tell #:type _NSInteger (tell NSPageLayout pageLayout) runModalWithPrintInfo: print-info) + NSOkButton) + (begin + (let ([o (tell #:type _int print-info orientation)]) + (send pss set-orientation (if (= o NSLandscapeOrientation) + 'landscape + 'portrait))) + (let ([s (tell #:type _CGFloat print-info scalingFactor)]) + (send pss set-scaling s s)) + #t) + #f))) (define printer-dc% (class (record-dc-mixin (dc-mixin bitmap-dc-backend%)) diff --git a/collects/mred/private/wx/gtk/printer-dc.rkt b/collects/mred/private/wx/gtk/printer-dc.rkt index 38819ef7..4cce51ef 100644 --- a/collects/mred/private/wx/gtk/printer-dc.rkt +++ b/collects/mred/private/wx/gtk/printer-dc.rkt @@ -1,14 +1,230 @@ #lang racket/base (require racket/class - racket/draw/dc) + racket/draw/local + racket/draw/dc + racket/draw/cairo + racket/draw/bitmap + racket/draw/bitmap-dc + racket/draw/record-dc + racket/draw/ps-setup + ffi/unsafe + ffi/unsafe/objc + ffi/unsafe/alloc + "../common/queue.rkt" + "widget.rkt" + "utils.rkt" + "types.rkt") -(provide printer-dc%) +(provide printer-dc% + show-print-setup) -(define dc-backend% - (class default-dc-backend% - (init [parent #f]) - - (super-new))) +(define GTK_UNIT_POINTS 1) + +(define GTK_PRINT_OPERATION_ACTION_PRINT_DIALOG 0) + +(define GTK_PRINT_OPERATION_RESULT_ERROR 0) +(define GTK_PRINT_OPERATION_RESULT_APPLY 1) +(define GTK_PRINT_OPERATION_RESULT_CANCEL 2) +(define GTK_PRINT_OPERATION_RESULT_IN_PROGRESS 3) + +(define GTK_PAGE_ORIENTATION_PORTRAIT 0) +(define GTK_PAGE_ORIENTATION_LANDSCAPE 1) +(define GTK_PAGE_ORIENTATION_REVERSE_PORTRAIT 2) +(define GTK_PAGE_ORIENTATION_REVERSE_LANDSCAPE 3) + +(define _GtkPageSetup (_cpointer/null 'GtkPageSetup)) +(define _GtkPrintSettings (_cpointer/null 'GtkPrintSettings)) +(define _GtkPrintOperation _GtkWidget) ; not really, but we connect signals... +(define _GtkPrintContext (_cpointer/null 'GtkPrintContext)) + +(define-gtk gtk_page_setup_new (_fun -> _GtkPageSetup) + #:wrap (allocator gobject-unref)) +(define-gtk gtk_page_setup_copy (_fun _GtkPageSetup -> _GtkPageSetup) + #:wrap (allocator gobject-unref)) +(define allocated-page-setup ((allocator gobject-unref) values)) + +(define-gtk gtk_print_settings_new (_fun -> _GtkPrintSettings) + #:wrap (allocator gobject-unref)) + +(define-gtk gtk_page_setup_get_paper_height (_fun _GtkPageSetup _int -> _double)) +(define-gtk gtk_page_setup_get_paper_width (_fun _GtkPageSetup _int -> _double)) +(define-gtk gtk_page_setup_get_left_margin (_fun _GtkPageSetup _int -> _double)) +(define-gtk gtk_page_setup_get_right_margin (_fun _GtkPageSetup _int -> _double)) +(define-gtk gtk_page_setup_get_top_margin (_fun _GtkPageSetup _int -> _double)) +(define-gtk gtk_page_setup_get_bottom_margin (_fun _GtkPageSetup _int -> _double)) + +(define-gtk gtk_page_setup_get_orientation (_fun _GtkPageSetup -> _int)) +(define-gtk gtk_page_setup_set_orientation (_fun _GtkPageSetup _int -> _void)) + +(define-gtk gtk_print_operation_new (_fun -> _GtkPrintOperation) + #:wrap (allocator gobject-unref)) + +(define-gtk gtk_print_operation_set_default_page_setup (_fun _GtkPrintOperation _GtkPageSetup + -> _void)) +(define-gtk gtk_print_operation_run (_fun _GtkPrintOperation + _int + (_or-null _GtkWindow) + (_ptr o _pointer) + -> _int)) + +(define-gtk gtk_print_operation_set_allow_async (_fun _GtkPrintOperation _gboolean -> _void)) +(define-gtk gtk_print_operation_set_n_pages (_fun _GtkPrintOperation _int -> _void)) + +(define-gtk gtk_print_context_get_cairo_context (_fun _GtkPrintContext -> _cairo_t)) + +(define-gtk gtk_print_run_page_setup_dialog_async (_fun (_or-null _GtkWindow) + _GtkPageSetup + _GtkPrintSettings + _fpointer + _pointer + -> _void)) + +(define (print-setup-done page-setup cb) + ((ptr-ref cb _racket) page-setup)) +(define print_setup_done (function-ptr print-setup-done + (_fun _GtkPageSetup _pointer -> _void))) + +(define (pss-install-page-setup pss page-setup) + (gtk_page_setup_set_orientation page-setup (if (eq? (send pss get-orientation) 'landscape) + GTK_PAGE_ORIENTATION_LANDSCAPE + GTK_PAGE_ORIENTATION_PORTRAIT))) + +(define (show-print-setup parent) + (let* ([pss (current-ps-setup)] + [page-setup (or (send pss get-native) + (let ([ps (gtk_page_setup_new)]) + (send pss set-native ps gtk_page_setup_copy) + ps))] + [print-settings (gtk_print_settings_new)] + [sema (make-semaphore)] + [done-page-setup #f] + [cell (malloc-immobile-cell (lambda (ps) + (set! done-page-setup (and ps + (allocated-page-setup ps))) + (semaphore-post sema)))]) + (pss-install-page-setup pss page-setup) + (gtk_print_run_page_setup_dialog_async (and parent + (send parent get-gtk)) + page-setup + print-settings + print_setup_done + cell) + (yield sema) + ;; `ptr-set!'s are a hack to ensure that the objects are not GCed: + (ptr-set! cell _racket page-setup) + (ptr-set! cell _racket print-settings) + (free-immobile-cell cell) + (and done-page-setup + (begin + (send pss set-native done-page-setup gtk_page_setup_copy) + (send pss set-orientation (if (member + (gtk_page_setup_get_orientation done-page-setup) + (list GTK_PAGE_ORIENTATION_LANDSCAPE + GTK_PAGE_ORIENTATION_REVERSE_LANDSCAPE)) + 'landscape + 'portrait)) + #t)))) + +(define-signal-handler connect-begin-print "begin-print" + (_fun _GtkPrintOperation _GtkPrintContext -> _void) + (lambda (op-gtk ctx-gtk) + (void))) + +(define-signal-handler connect-draw-page "draw-page" + (_fun _GtkPrintOperation _GtkPrintContext _int -> _void) + (lambda (op-gtk ctx-gtk page-no) + (let ([wx (gtk->wx op-gtk)]) + (when wx + (send wx draw-page ctx-gtk page-no))))) + +(define-signal-handler connect-done "done" + (_fun _GtkPrintOperation _int -> _void) + (lambda (op-gtk res) + (when (= res GTK_PRINT_OPERATION_RESULT_CANCEL) + (let ([wx (gtk->wx op-gtk)]) + (when wx + (send wx done)))))) + +(define-signal-handler connect-end-print "end-print" + (_fun _GtkPrintOperation _GtkPrintContext -> _void) + (lambda (op-gtk ctx-gtk) + (let ([wx (gtk->wx op-gtk)]) + (when wx + (send wx done))))) + +(define printout% + (class widget% + (init-field op-gtk + pages + page-setup) + (super-new [gtk op-gtk]) + + (connect-begin-print op-gtk) + (connect-draw-page op-gtk) + (connect-done op-gtk) + (connect-end-print op-gtk) + + (gtk_print_operation_set_n_pages op-gtk (length pages)) + (gtk_print_operation_set_allow_async op-gtk #t) + (gtk_print_operation_set_default_page_setup op-gtk page-setup) + + (define done-sema (make-semaphore)) + + (define/public (go) + (let ([res (gtk_print_operation_run op-gtk + GTK_PRINT_OPERATION_ACTION_PRINT_DIALOG + #f)]) + (yield done-sema))) + + (define/public (draw-page ctx-gtk pageno) + (let ([cr (gtk_print_context_get_cairo_context ctx-gtk)]) + ((list-ref pages pageno) + (make-object + (class (dc-mixin default-dc-backend%) + (super-new) + (define orig-matrix (make-cairo_matrix_t 0.0 0.0 0.0 0.0 0.0 0.0)) + (cairo_get_matrix cr orig-matrix) + (define/override (init-cr-matrix cr) (cairo_set_matrix cr orig-matrix)) + (define/override (get-cr) cr)))))) + + (define/public (done) + (semaphore-post done-sema)))) (define printer-dc% - (dc-mixin dc-backend%)) + (class (record-dc-mixin (dc-mixin bitmap-dc-backend%)) + (init [parent #f]) + + (super-make-object (make-object bitmap% 1 1)) + + (inherit get-recorded-command + reset-recording) + + (define pages null) + (define/override (end-page) + (set! pages (cons (get-recorded-command) pages)) + (reset-recording)) + + (define page-setup (or (let-values ([(ps copier) + (send (current-ps-setup) + get-native-copy)]) + ps) + (gtk_page_setup_new))) + (pss-install-page-setup (current-ps-setup) page-setup) + + (define page-width (- (gtk_page_setup_get_paper_width page-setup GTK_UNIT_POINTS) + (gtk_page_setup_get_left_margin page-setup GTK_UNIT_POINTS) + (gtk_page_setup_get_right_margin page-setup GTK_UNIT_POINTS))) + (define page-height (- (gtk_page_setup_get_paper_height page-setup GTK_UNIT_POINTS) + (gtk_page_setup_get_top_margin page-setup GTK_UNIT_POINTS) + (gtk_page_setup_get_bottom_margin page-setup GTK_UNIT_POINTS))) + (define page-scaling 1.0) ; scale from gtk_print_operation_run is too late + + (define/override (get-size) + (values (/ page-width page-scaling) (/ page-height page-scaling))) + + (define/override (end-doc) + (send (new printout% + [op-gtk (gtk_print_operation_new)] + [pages (reverse pages)] + [page-setup page-setup]) + go)))) diff --git a/collects/mred/private/wx/gtk/procs.rkt b/collects/mred/private/wx/gtk/procs.rkt index 6b77bd50..ad1687fd 100644 --- a/collects/mred/private/wx/gtk/procs.rkt +++ b/collects/mred/private/wx/gtk/procs.rkt @@ -11,7 +11,9 @@ "widget.rkt" "window.rkt" "dc.rkt" + "printer-dc.rkt" "gl-context.rkt" + "../common/printer.rkt" "../common/handlers.rkt") (provide @@ -72,7 +74,9 @@ (case-lambda [(path cr ty) (void)] [(path) (values #"????" #"????")])) -(define-unimplemented run-printout) + +(define run-printout (make-run-printout printer-dc%)) + (define (get-double-click-time) 250) (define-unimplemented key-symbol-to-integer) (define (get-control-font-size) 10) ;; FIXME @@ -101,8 +105,7 @@ (define-unimplemented is-color-display?) (define (id-to-menu-item i) i) -(define-unimplemented show-print-setup) -(define (can-show-print-setup?) #f) +(define (can-show-print-setup?) #t) (define (get-highlight-background-color) (let-values ([(r g b) (get-selected-background-color)]) diff --git a/collects/mred/private/wxme/editor.rkt b/collects/mred/private/wxme/editor.rkt index 27138274..0c10ec66 100644 --- a/collects/mred/private/wxme/editor.rkt +++ b/collects/mred/private/wxme/editor.rkt @@ -744,9 +744,7 @@ [any? [parent #f]] ; checked in ../editor.ss [bool? [force-page-bbox? #t]] [bool? [as-eps? #f]]) - (let ([ps? (case (system-type) - [(macosx windows) (eq? output-mode 'postscript)] - [else #t])] + (let ([ps? (eq? output-mode 'postscript)] [parent (or parent (extract-parent))]) (cond