216 lines
8.0 KiB
Racket
216 lines
8.0 KiB
Racket
#lang racket/base
|
|
(require racket/class
|
|
racket/math
|
|
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/objc
|
|
"../../lock.rkt"
|
|
"dc.rkt"
|
|
"frame.rkt"
|
|
"cg.rkt"
|
|
"utils.rkt"
|
|
"types.rkt"
|
|
"queue.rkt")
|
|
|
|
(provide
|
|
(protect-out printer-dc%
|
|
show-print-setup))
|
|
|
|
(import-class NSPrintOperation NSView NSGraphicsContext
|
|
NSPrintInfo NSDictionary NSPageLayout
|
|
NSNumber)
|
|
|
|
(define NSPortraitOrientation 0)
|
|
(define NSLandscapeOrientation 1)
|
|
|
|
(define-cocoa NSPrintScalingFactor _id)
|
|
|
|
(define-objc-class PrinterView NSView
|
|
[wxb]
|
|
[-a _BOOL (knowsPageRange: [_NSRange-pointer rng])
|
|
(set-NSRange-location! rng 1)
|
|
(set-NSRange-length! rng (let ([wx (->wx wxb)])
|
|
(if wx
|
|
(send wx get-page-count)
|
|
0)))
|
|
#t]
|
|
[-a _NSRect (rectForPage: [_NSInteger n])
|
|
(let ([wx (->wx wxb)])
|
|
(if wx
|
|
(send wx get-rect-for-page n)
|
|
(make-NSRect (make-NSPoint 0 0)
|
|
(make-NSSize 10 10))))]
|
|
[-a _void (beginPageInRect: [_NSRect aRect] atPlacement: [_NSPoint location])
|
|
(let ([wx (->wx wxb)])
|
|
(when wx
|
|
(send wx start-page-at aRect)))
|
|
(super-tell #:type _void beginPageInRect: #:type _NSRect aRect atPlacement: #:type _NSPoint location)]
|
|
[-a _void (drawPageBorderWithSize: [_NSSize size])
|
|
(let ([wx (->wx wxb)])
|
|
(when wx
|
|
(send wx draw-print-page self size)))])
|
|
|
|
(define (make-print-info [prev #f])
|
|
(as-objc-allocation-with-retain
|
|
(tell (tell NSPrintInfo alloc)
|
|
initWithDictionary:
|
|
(if prev
|
|
(tell prev dictionary)
|
|
(tell NSDictionary dictionary)))))
|
|
|
|
(define (get-scaling-factor print-info)
|
|
;; 10.6 only:
|
|
#;
|
|
(tell #:type _CGFloat print-info scalingFactor)
|
|
(atomically
|
|
(with-autorelease
|
|
(tell #:type _double
|
|
(tell (tell print-info dictionary)
|
|
objectForKey: NSPrintScalingFactor)
|
|
doubleValue))))
|
|
|
|
(define (install-pss-to-print-info pss print-info)
|
|
(tellv print-info setOrientation: #:type _int (if (eq? (send pss get-orientation) 'landscape)
|
|
NSLandscapeOrientation
|
|
NSPortraitOrientation))
|
|
(let ([scale (let ([x (box 0)]
|
|
[y (box 0)])
|
|
(send pss get-scaling x y)
|
|
(unbox y))])
|
|
;; 10.6 only:
|
|
#;
|
|
(tellv print-info setScalingFactor: #:type _CGFloat scale)
|
|
(atomically
|
|
(with-autorelease
|
|
(tellv (tell print-info dictionary)
|
|
setObject: (tell NSNumber numberWithDouble: #:type _double scale)
|
|
forKey: NSPrintScalingFactor)))))
|
|
|
|
(define NSOkButton 1)
|
|
|
|
(define (show-print-setup parent)
|
|
(promote-to-gui!)
|
|
(let* ([pss (current-ps-setup)]
|
|
[print-info (let ([pi (send pss get-native)])
|
|
(or pi
|
|
(let ([pi (make-print-info)])
|
|
(send pss set-native pi make-print-info)
|
|
pi)))])
|
|
(install-pss-to-print-info pss print-info)
|
|
(if (atomically
|
|
(let ([front (get-front)])
|
|
(begin0
|
|
(= (tell #:type _NSInteger (tell NSPageLayout pageLayout) runModalWithPrintInfo: print-info)
|
|
NSOkButton)
|
|
(when front
|
|
(tellv (send front get-cocoa-window) makeKeyAndOrderFront: #f)))))
|
|
(begin
|
|
(let ([o (tell #:type _int print-info orientation)])
|
|
(send pss set-orientation (if (= o NSLandscapeOrientation)
|
|
'landscape
|
|
'portrait)))
|
|
(let ([s (get-scaling-factor print-info)])
|
|
(send pss set-scaling s s))
|
|
#t)
|
|
#f)))
|
|
|
|
(define printer-dc%
|
|
(class (record-dc-mixin (dc-mixin bitmap-dc-backend%))
|
|
(init [parent #f])
|
|
|
|
(super-make-object (make-object quartz-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 print-info (or (let-values ([(pi copier)
|
|
(send (current-ps-setup)
|
|
get-native-copy)])
|
|
pi)
|
|
(make-print-info)))
|
|
|
|
(install-pss-to-print-info (current-ps-setup) print-info)
|
|
|
|
(define-values (page-width page-height page-scaling)
|
|
(let ([s (NSRect-size (tell #:type _NSRect print-info imageablePageBounds))]
|
|
[scaling (get-scaling-factor print-info)])
|
|
(values (NSSize-width s)
|
|
(NSSize-height s)
|
|
scaling)))
|
|
|
|
(define/override (get-size)
|
|
(values (/ page-width page-scaling) (/ page-height page-scaling)))
|
|
|
|
(define/override (get-device-scale)
|
|
(values page-scaling page-scaling))
|
|
|
|
(define current-page 0)
|
|
|
|
(define/public (get-page-count) (length pages))
|
|
(define/public (get-rect-for-page i)
|
|
(make-NSRect (make-NSPoint 0 (* (sub1 i) page-height))
|
|
(make-NSSize page-width page-height)))
|
|
(define/public (start-page-at r)
|
|
(set! current-page (inexact->exact (round (/ (NSPoint-y (NSRect-origin r)) page-height)))))
|
|
(define/public (draw-print-page view-cocoa s)
|
|
(let ([f (tell #:type _NSRect view-cocoa frame)])
|
|
(tellv view-cocoa lockFocus)
|
|
|
|
(let ([cg (tell #:type _CGContextRef (tell NSGraphicsContext currentContext) graphicsPort)]
|
|
[s (tell #:type _NSSize print-info paperSize)]
|
|
[b (tell #:type _NSRect print-info imageablePageBounds)])
|
|
(CGContextTranslateCTM cg 0 (/ (NSSize-height s) page-scaling))
|
|
(CGContextScaleCTM cg 1 -1)
|
|
(CGContextTranslateCTM cg
|
|
(/ (NSPoint-x (NSRect-origin b)) page-scaling)
|
|
(/ (- (NSSize-height s)
|
|
(+ (NSPoint-y (NSRect-origin b))
|
|
(NSSize-height (NSRect-size b))))
|
|
page-scaling))
|
|
(let* ([surface (cairo_quartz_surface_create_for_cg_context
|
|
cg
|
|
(inexact->exact (ceiling (/ page-width page-scaling)))
|
|
(inexact->exact (ceiling (/ page-height page-scaling))))]
|
|
[cr (cairo_create surface)])
|
|
(cairo_surface_destroy surface)
|
|
(let ([dc (make-object (dc-mixin
|
|
(class default-dc-backend%
|
|
(define/override (get-cr) cr)
|
|
(super-new))))])
|
|
(let ([proc (list-ref (reverse pages) current-page)])
|
|
(proc dc)))
|
|
(cairo_destroy cr)))
|
|
|
|
(tellv view-cocoa unlockFocus)))
|
|
|
|
(define/override (end-doc)
|
|
(promote-to-gui!)
|
|
|
|
(define view-cocoa (as-objc-allocation-with-retain
|
|
(tell (tell PrinterView alloc)
|
|
initWithFrame: #:type _NSRect (make-NSRect
|
|
(make-NSPoint 0 0)
|
|
(make-NSSize 10 10)))))
|
|
(define op-cocoa (as-objc-allocation-with-retain
|
|
(tell NSPrintOperation printOperationWithView: view-cocoa
|
|
printInfo: print-info)))
|
|
|
|
(set-ivar! view-cocoa wxb (->wxb this))
|
|
|
|
(atomically
|
|
(let ([front (get-front)])
|
|
(tellv op-cocoa runOperation)
|
|
(when front
|
|
(tellv (send front get-cocoa-window) makeKeyAndOrderFront: #f)))))))
|