From 58b792203370973acda3741fafdd168962a6f4f4 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Mon, 8 Nov 2010 18:36:39 -0700
Subject: [PATCH] use Racket file I/O for post-script-dc%

---
 .../racket/draw/private/post-script-dc.rkt    | 41 ++++++++++++++-----
 collects/racket/draw/unsafe/cairo.rkt         |  7 ++++
 2 files changed, 37 insertions(+), 11 deletions(-)

diff --git a/collects/racket/draw/private/post-script-dc.rkt b/collects/racket/draw/private/post-script-dc.rkt
index b13099137c..287466a7c8 100644
--- a/collects/racket/draw/private/post-script-dc.rkt
+++ b/collects/racket/draw/private/post-script-dc.rkt
@@ -1,11 +1,14 @@
-#lang scheme/base
-(require scheme/class
-         scheme/file
+#lang racket/base
+(require racket/class
+         racket/file
          racket/path
          racket/math
          "syntax.rkt"
          racket/gui/dynamic
+         ffi/unsafe
+         ffi/unsafe/alloc
          "../unsafe/cairo.ss"
+         "../unsafe/bstr.ss"
 	 "dc.ss"
          "font.ss"
          "local.ss"
@@ -20,7 +23,7 @@
           [use-paper-bbox #f]
           [as-eps #t])
 
-    (define-values (s width height landscape?)
+    (define-values (s port-box width height landscape?)
       (let ([su (if interactive
                     ((gui-dynamic-require 'get-ps-setup-from-user) #f parent)
                     (current-ps-setup))])
@@ -45,16 +48,21 @@
                          #f)])
             (if (and to-file?
                      (not fn))
-                (values #f #f #f #f)
+                (values #f #f #f #f #f)
                 (let* ([paper (assoc (send pss get-paper-name) paper-sizes)]
                        [w (cadr paper)]
                        [h (caddr paper)]
-                       [landscape? (eq? (send pss get-orientation) 'landscape)])
+                       [landscape? (eq? (send pss get-orientation) 'landscape)]
+                       [file (open-output-file
+                              (or fn (make-temporary-file "draw~a.ps"))
+                              #:exists 'truncate/replace)]
+                       [port-box (make-immobile file)])
                   (values
-                   (cairo_ps_surface_create (or fn
-                                                (make-temporary-file "draw~a.ps"))
-                                            w
-                                            h)
+                   (cairo_ps_surface_create_for_stream write_port_bytes
+                                                       port-box
+                                                       w
+                                                       h)
+                   port-box ; needs to be accessible as long as `s'
                    w
                    h
                    landscape?))))]
@@ -98,7 +106,9 @@
       (cairo_surface_finish s)
       (cairo_destroy c)
       (set! c #f)
-      (set! s #f))
+      (set! s #f)
+      (close-output-port (ptr-ref port-box _racket))
+      (set! port-box #f))
 
     (define/override (init-cr-matrix c)
       (cairo_translate c trans-x trans-y)
@@ -129,3 +139,12 @@
     (super-new)))
 
 (define post-script-dc% (dc-mixin dc-backend%))
+
+(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 write_port_bytes (function-ptr write-port-bytes _cairo_write_func_t))
+
+(define make-immobile ((allocator free-immobile-cell) malloc-immobile-cell))
diff --git a/collects/racket/draw/unsafe/cairo.rkt b/collects/racket/draw/unsafe/cairo.rkt
index c94c375359..78712b5b97 100644
--- a/collects/racket/draw/unsafe/cairo.rkt
+++ b/collects/racket/draw/unsafe/cairo.rkt
@@ -195,6 +195,13 @@
   #: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))
+(define/provide _cairo_write_func_t (_fun _pointer _pointer _uint -> _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;