Add pict->pdf.

1 files changed, 26 insertions, 0 deletions

diff --git a/pict.scm b/pict.scm
index 34dfe84..3e3f11a 100644
--- a/pict.scm
+++ b/pict.scm
@@ -41,6 +41,7 @@
             pict-height
             pict-rotation
             pict->file
+            pict->pdf
             pict-from-file
 
             ;; modifiers
@@ -150,6 +151,31 @@ the file to determine the file name.  Return the file name."
      (format port "#<Image: ~a>" name))))
 
 (define %dpi 72) ; like cairo
+
+(define* (pict->pdf pict out #:key page-height page-width)
+  "Read SVG from picture PICT and write a PDF file to OUT."
+  (define svg
+    `(svg (@ (width ,(pict-width pict))
+             (height ,(pict-height pict))
+             (xmlns "http://www.w3.org/2000/svg"))
+          ,(pict-sxml pict)))
+  (let* ((port (mkstemp! (string-copy "/tmp/pictXXXXXXX")))
+         (name (port-filename port)))
+    (sxml->xml svg port)
+    (close-port port)
+    (let*-values (((d) (rsvg-set-default-dpi-x-y %dpi %dpi))
+                  ((handle) (rsvg-handle-new-from-file name))
+                  ((c) (rsvg-handle-close handle))
+                  ((width height em ex) (rsvg-handle-get-dimensions handle)))
+      (let* ((surf (if (and page-height page-width)
+                       (cairo-pdf-surface-create page-width page-height out)
+                       (cairo-pdf-surface-create width height out)))
+             (ctx (cairo-create surf)))
+        (rsvg-handle-render-cairo handle ctx)
+        (cairo-show-page ctx)
+        (cairo-surface-finish surf)
+        out))))
+
 
 ;;; Miscellaneous utilities