1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
| | ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (guix build svg)
#:use-module (ice-9 match)
#:use-module (system foreign)
#:use-module (rnrs bytevectors)
#:export (svg->png))
(define (null-check! message)
(match-lambda
((? null-pointer?)
(error message))
(pointer pointer)))
(define (int-bool-check! message)
(match-lambda
(0 (error message))
(_ #t)))
(define CAIRO_STATUS_SUCCESS 0)
(define (cairo-status-check! message)
(lambda (status)
(or (= status CAIRO_STATUS_SUCCESS)
(error message status))))
(define* (svg->png svg png #:key width height librsvg)
"Build a PNG of size WIDTH and HEIGHT from SVG using LIBRSVG.
If omitted, WIDTH and HEIGHT default to the natural image size."
(define library
(dynamic-link (if librsvg
(string-append librsvg "/lib/librsvg-2.so")
"librsvg-2.so")))
(define (c-function return-type name arg-types)
(pointer->procedure return-type (dynamic-func name library) arg-types))
(define rsvg-handle-new-from-file
(compose (null-check! "rsvg-handle-new-from-file failed")
(c-function '* "rsvg_handle_new_from_file" '(* *))
(lambda (name)
(values (string->pointer name)
(make-c-struct '(*) (list %null-pointer))))))
(define rsvg-handle-get-dimensions
(let ((get-dimensions*
(c-function void "rsvg_handle_get_dimensions" '(* *)))
(type (list int int double double)))
(lambda (handle)
(let ((dimensions (make-c-struct type '(0 0 0 0))))
(get-dimensions* handle dimensions)
(parse-c-struct dimensions type)))))
(define rsvg-handle-render-cairo
(compose (int-bool-check! "rsvg-handle-render-cairo failed")
(c-function int "rsvg_handle_render_cairo" '(* *))))
(define g-object-unref
(c-function void "g_object_unref" '(*)))
(define CAIRO_FORMAT_ARGB32 0)
(define cairo-image-surface-create
(compose (null-check! "cairo-image-surface-create failed")
(c-function '* "cairo_image_surface_create"
(list int int int))))
(define cairo-create (compose (null-check! "cairo-create failed")
(c-function '* "cairo_create" '(*))))
(define cairo-scale (c-function void "cairo_scale" (list '* double double)))
(define cairo-destroy (c-function void "cairo_destroy" '(*)))
(define cairo-surface-destroy (c-function void "cairo_surface_destroy" '(*)))
(define cairo-surface-write-to-png
(compose (cairo-status-check! "cairo-surface-write-to-png failed")
(c-function int "cairo_surface_write_to_png" '(* *))
(lambda (surface name)
(values surface (string->pointer name)))))
(let ((rsvg-handle (rsvg-handle-new-from-file svg)))
(match (rsvg-handle-get-dimensions rsvg-handle)
((natural-width natural-height . _)
(let* ((width (or width natural-width))
(height (or height natural-height))
(surface (cairo-image-surface-create CAIRO_FORMAT_ARGB32
width height))
(cr (cairo-create surface)))
(cairo-scale cr (/ width natural-width) (/ height natural-height))
(rsvg-handle-render-cairo rsvg-handle cr)
(g-object-unref rsvg-handle)
(cairo-surface-write-to-png surface png)
(cairo-destroy cr)
(cairo-surface-destroy surface)
#t)))))
|