gnu/build/svg.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
   3 ;;; Copyright © 2015 Andy Wingo <wingo@igalia.com>
   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 (srfi srfi-11)
  22   #:export (svg->png))
  23
  24 ;; We need Guile-RSVG and Guile-Cairo.  Load them lazily, at run time, to
  25 ;; allow compilation to proceed.  See also <http://bugs.gnu.org/12202>.
  26 (module-autoload! (current-module)
  27                   '(rsvg) '(rsvg-handle-new-from-file))
  28 (module-autoload! (current-module)
  29                   '(cairo) '(cairo-image-surface-create))
  30
  31 (define* (downscaled-surface surface
  32                              #:key
  33                              source-width source-height
  34                              width height)
  35   "Return a new rendering context where SURFACE is scaled to WIDTH x HEIGHT."
  36   (let ((cr (cairo-create (cairo-image-surface-create 'argb32
  37                                                       width height))))
  38     (cairo-scale cr (/ width source-width) (/ height source-height))
  39     (cairo-set-source-surface cr surface 0 0)
  40     (cairo-pattern-set-filter (cairo-get-source cr) 'best)
  41     (cairo-rectangle cr 0 0 source-width source-height)
  42     (cairo-fill cr)
  43     cr))
  44
  45 (define* (svg->png in-svg out-png
  46                    #:key width height)
  47   "Render the file at IN-SVG as a PNG file in OUT-PNG.  When WIDTH and HEIGHT
  48 are provided, use them as the dimensions of OUT-PNG; otherwise preserve the
  49 dimensions of IN-SVG."
  50   (define svg
  51     (rsvg-handle-new-from-file in-svg))
  52
  53   (let-values (((origin-width origin-height)
  54                 (rsvg-handle-get-dimensions svg)))
  55     (let* ((surf (cairo-image-surface-create 'argb32
  56                                              origin-width origin-height))
  57            (cr   (cairo-create surf)))
  58       (rsvg-handle-render-cairo svg cr)
  59       (cairo-surface-flush surf)
  60       (let ((cr (if (and width height
  61                          (not (= width origin-width))
  62                          (not (= height origin-height)))
  63                     (downscaled-surface surf
  64                                         #:source-width origin-width
  65                                         #:source-height origin-height
  66                                         #:width width
  67                                         #:height height)
  68                     cr)))
  69         (cairo-surface-write-to-png (cairo-get-target cr) out-png)))))
  70
  71 ;;; svg.scm ends here