projects/guix·blob javascript-team · refs

66 lines · 2.8 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2016, 2017, 2018 Ludovic Courtès <[email protected]>
3;;; Copyright © 2015 Andy Wingo <[email protected]>
4;;;
5;;; This file is part of GNU Guix.
6;;;
7;;; GNU Guix is free software; you can redistribute it and/or modify it
8;;; under the terms of the GNU General Public License as published by
9;;; the Free Software Foundation; either version 3 of the License, or (at
10;;; your option) any later version.
11;;;
12;;; GNU Guix is distributed in the hope that it will be useful, but
13;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;;; GNU General Public License for more details.
16;;;
17;;; You should have received a copy of the GNU General Public License
18;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19
20(define-module (gnu build svg)
21 #:use-module (rsvg)
22 #:use-module (cairo)
23 #:use-module (srfi srfi-11)
24 #:export (svg->png))
25
26(define* (downscaled-surface surface
27 #:key
28 source-width source-height
29 width height)
30 "Return a new rendering context where SURFACE is scaled to WIDTH x HEIGHT."
31 (let ((cr (cairo-create (cairo-image-surface-create 'argb32
32 width height))))
33 (cairo-scale cr (/ width source-width) (/ height source-height))
34 (cairo-set-source-surface cr surface 0 0)
35 (cairo-pattern-set-filter (cairo-get-source cr) 'best)
36 (cairo-rectangle cr 0 0 source-width source-height)
37 (cairo-fill cr)
38 cr))
39
40(define* (svg->png in-svg out-png
41 #:key width height)
42 "Render the file at IN-SVG as a PNG file in OUT-PNG. When WIDTH and HEIGHT
43are provided, use them as the dimensions of OUT-PNG; otherwise preserve the
44dimensions of IN-SVG."
45 (define svg
46 (rsvg-handle-new-from-file in-svg))
47
48 (let-values (((origin-width origin-height em ex)
49 (rsvg-handle-get-dimensions svg)))
50 (let* ((surf (cairo-image-surface-create 'argb32
51 origin-width origin-height))
52 (cr (cairo-create surf)))
53 (rsvg-handle-render-cairo svg cr)
54 (cairo-surface-flush surf)
55 (let ((cr (if (and width height
56 (not (= width origin-width))
57 (not (= height origin-height)))
58 (downscaled-surface surf
59 #:source-width origin-width
60 #:source-height origin-height
61 #:width width
62 #:height height)
63 cr)))
64 (cairo-surface-write-to-png (cairo-get-target cr) out-png)))))
65
66;;; svg.scm ends here