suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix port as PostScript/PDF/SVG destination

Browse Source 
by putting port-calling work in a specific thread
This commit is contained in:
Matthew Flatt 2011-01-18 19:44:04 -07:00
parent 4fc8797df2
commit 784c3de563
5 changed files with 89 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
collects/racket/draw/private/post-script-dc.rkt
View File

@ -40,7 +40,7 @@
(output-port? output))
(raise-type-error (get-name) "path string, output port, or #f" output)))
(define-values (s port-box close-port? width height landscape?)
(define-values (s port close-port? writer width height landscape?)
(let ([su (if interactive
((gui-dynamic-require 'get-ps-setup-from-user) #f parent)
(current-ps-setup))])
@ -68,7 +68,7 @@
#f)])
(if (and to-file?
(not fn))
(values #f #f #f #f #f #f)
(values #f #f #f #f #f #f #f)
(let* ([paper (assoc (send pss get-paper-name) paper-sizes)]
[w (if (or (not init-w) use-paper-bbox)
(cadr paper)
@ -83,26 +83,26 @@
(or fn (make-temporary-file (if pdf?
"draw~a.pdf"
"draw~a.ps")))
#:exists 'truncate/replace))]
[port-box (make-immobile file)])
#:exists 'truncate/replace))])
(let-values ([(w h) (if (and pdf? landscape?)
(values h w)
(values w h))])
(values w h))]
[(writer proc) (make-port-writer file)])
(values
((if pdf?
cairo_pdf_surface_create_for_stream
cairo_ps_surface_create_for_stream)
write_port_bytes
port-box
proc
w
h)
port-box ; needs to be accessible as long as `s'
file
(not (output-port? fn))
writer
w
h
landscape?)))))]
[else
(values #f #f #f #f #f #f)])))
(values #f #f #f #f #f #f #f)])))
(define-values (margin-x margin-y)
(if as-eps
@ -147,9 +147,11 @@
(cairo_destroy c)
(set! c #f)
(set! s #f)
(port-writer-wait writer)
(set! writer #f)
(when close-port?
(close-output-port (ptr-ref port-box _racket)))
(set! port-box #f))
(close-output-port port))
(set! port #f))
(define/override (init-cr-matrix c)
(cairo_translate c trans-x trans-y)

27
collects/racket/draw/private/svg-dc.rkt
View File

@ -40,16 +40,17 @@
(define height init-h)
(define close-port? (path-string? init-output))
(define port-box ; needs to be accessible as long as `s' or `c'
(let ([output (if (output-port? init-output)
init-output
(open-output-file init-output #:exists exists))])
(make-immobile output)))
(define s (cairo_svg_surface_create_for_stream
write_port_bytes
port-box
width
height))
(define port
(if (output-port? init-output)
init-output
(open-output-file init-output #:exists exists)))
(define-values (s writer)
(let-values ([(writer proc) (make-port-writer port)])
(values (cairo_svg_surface_create_for_stream
proc
width
height)
writer)))
(define c (and s (cairo_create s)))
(when s (cairo_surface_destroy s))
@ -66,9 +67,11 @@
(cairo_destroy c)
(set! c #f)
(set! s #f)
(port-writer-wait writer)
(set! writer #f)
(when close-port?
(close-output-port (ptr-ref port-box _racket)))
(set! port-box #f))
(close-output-port port))
(set! port #f))
(define/override (get-pango font)
(send font get-pango))

27
collects/racket/draw/private/write-bytes.rkt
View File

@ -4,14 +4,25 @@
"../unsafe/cairo.ss"
"../unsafe/bstr.ss")
(provide write_port_bytes
make-immobile)
(provide make-port-writer
port-writer-wait)
(define (write-port-bytes port-box bytes len)
(write-bytes (scheme_make_sized_byte_string bytes len 0)
(ptr-ref port-box _racket))
CAIRO_STATUS_SUCCESS)
(define (make-port-writer port)
(let ([t (thread/suspend-to-kill
(lambda ()
(let loop ()
(let ([msg (thread-receive)])
(when (bytes? msg)
(write-bytes msg port)
(loop))))))])
(values t
(lambda (bytes len)
(thread-send t (scheme_make_sized_byte_string bytes len 1)
void)
CAIRO_STATUS_SUCCESS))))
(define write_port_bytes (function-ptr write-port-bytes _cairo_write_func_t))
(define (port-writer-wait t)
(thread-resume t)
(thread-send t eof void)
(thread-wait t))
(define make-immobile ((allocator free-immobile-cell) malloc-immobile-cell))

49
collects/racket/draw/unsafe/cairo.rkt
View File

@ -237,21 +237,44 @@
#:wrap (allocator cairo_surface_destroy))
(define-cairo cairo_ps_surface_create (_fun _path _double* _double* -> _cairo_surface_t)
#:wrap (allocator cairo_surface_destroy))
(define-cairo cairo_ps_surface_create_for_stream
;; The _fpointer argument is _cairo_write_func_t
;; but it's saved as a callback, so care is needed with
;; allocation.
(_fun _fpointer _pointer _double* _double* -> _cairo_surface_t)
#:wrap (allocator cairo_surface_destroy))
;; Stream surfaces
;; The first argument to a stream-surface creation
;; function is a procedure, and we need the procedure to
;; live just as long as the surface. Implement that by
;; saving the closure via user data on the surface.
;; Externally, a stream-creation function takes
;; just a closure --- not a function and data.
(define _cairo_write_func_t
(_fun #:atomic? #t _pointer _pointer _uint -> _int))
(define _stream-surface-proc
(_fun _cairo_write_func_t _pointer _double* _double* -> _cairo_surface_t))
(define cell-key (malloc 1 'raw))
(define stream-surface-allocator
(lambda (p)
((allocator cairo_surface_destroy)
(lambda (proc w h)
(let* ([new-proc (lambda (null bytes len)
(proc bytes len))]
[s (p new-proc #f w h)]
[b (malloc-immobile-cell new-proc)])
(cairo_surface_set_user_data s cell-key b free-immobile-cell)
s)))))
(define-cairo cairo_ps_surface_create_for_stream
_stream-surface-proc
#:wrap stream-surface-allocator)
(define-cairo cairo_pdf_surface_create_for_stream
;; As above:
(_fun _fpointer _pointer _double* _double* -> _cairo_surface_t)
#:wrap (allocator cairo_surface_destroy))
_stream-surface-proc
#:wrap stream-surface-allocator)
(define-cairo cairo_svg_surface_create_for_stream
;; As above:
(_fun _fpointer _pointer _double* _double* -> _cairo_surface_t)
#:wrap (allocator cairo_surface_destroy))
(define/provide _cairo_write_func_t (_fun _pointer _pointer _uint -> _int))
_stream-surface-proc
#:wrap stream-surface-allocator)
(define-cairo cairo_surface_set_user_data
(_fun _cairo_surface_t _pointer _pointer (_fun #:atomic? #t _pointer -> _void)
-> _int))
(define-cairo cairo_ps_surface_set_eps (_fun _cairo_surface_t _bool -> _void)
#:fail (lambda ()
;; cairo_ps_surface_set_eps is in version 1.6 and later;

7
collects/scribblings/draw/post-script-dc-class.scrbl
View File

@ -57,7 +57,12 @@ If @scheme[use-paper-bbox] is @scheme[#f], then the PostScript
When @racket[output] is not @racket[#f], then file-mode output is
written to @racket[output]. If @racket[output] is @racket[#f], then
the destination is determined via @racket[current-ps-setup] or by
prompting the user for a pathname.
prompting the user for a pathname. When @racket[output] is a port,
then data is written to @racket[port] by a thread that is created
with the @racket[post-script-dc%] instance; in case that writing
thread's custodian is shut down, calling @method[dc<%> end-doc]
resumes the port-writing thread with @racket[thread-resume]
and @racket[(current-thread)] as the second argument.
See also @scheme[ps-setup%] and @scheme[current-ps-setup]. The
settings for a particular @scheme[post-script-dc%] object are fixed to