235 lines
9.4 KiB
Racket
235 lines
9.4 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
racket/draw/private/local
|
|
racket/draw/private/dc
|
|
racket/draw/unsafe/cairo
|
|
racket/draw/private/bitmap
|
|
racket/draw/private/bitmap-dc
|
|
racket/draw/private/record-dc
|
|
racket/draw/private/ps-setup
|
|
ffi/unsafe
|
|
ffi/unsafe/alloc
|
|
"../common/queue.rkt"
|
|
"widget.rkt"
|
|
"utils.rkt"
|
|
"types.rkt")
|
|
|
|
(provide
|
|
(protect-out printer-dc%
|
|
show-print-setup))
|
|
|
|
(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%
|
|
(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 (get-device-scale)
|
|
(values page-scaling page-scaling))
|
|
|
|
(define/override (end-doc)
|
|
(send (new printout%
|
|
[op-gtk (gtk_print_operation_new)]
|
|
[pages (reverse pages)]
|
|
[page-setup page-setup])
|
|
go)
|
|
(void))))
|