profiles: Build GTK+ input module cache.

* guix/profiles.scm (gtk-im-modules): New procedure.
(%default-profile-hooks): Add it.
This commit is contained in:
Ricardo Wurmus 2016-09-22 22:27:06 +02:00
parent 2c9f4786c9
commit 7ddc178093
No known key found for this signature in database
GPG Key ID: 197A5888235FACAC
1 changed files with 62 additions and 0 deletions

View File

@ -4,6 +4,7 @@
;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Sou Bunnbu <iyzsong@gmail.com>
;;; Copyright © 2016 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
@ -723,6 +724,66 @@ creates the GTK+ 'icon-theme.cache' file for each theme."
#:substitutable? #f)
(return #f))))
(define (gtk-im-modules manifest)
"Return a derivation that builds the cache files for input method modules
for both major versions of GTK+."
(mlet %store-monad ((gtk+ (manifest-lookup-package manifest "gtk+" "3"))
(gtk+-2 (manifest-lookup-package manifest "gtk+" "2")))
(define (build gtk gtk-version)
(let ((major (string-take gtk-version 1)))
(with-imported-modules '((guix build utils)
(guix build union)
(guix build profiles)
(guix search-paths)
(guix records))
#~(begin
(use-modules (guix build utils)
(guix build union)
(guix build profiles)
(ice-9 popen)
(srfi srfi-1)
(srfi srfi-26))
(let* ((prefix (string-append "/lib/gtk-" #$major ".0/"
#$gtk-version))
(query (string-append #$gtk "/bin/gtk-query-immodules-"
#$major ".0"))
(destdir (string-append #$output prefix))
(moddirs (cons (string-append #$gtk prefix "/immodules")
(filter file-exists?
(map (cut string-append <> prefix "/immodules")
'#$(manifest-inputs manifest)))))
(modules (append-map (cut find-files <> "\\.so$")
moddirs)))
;; Generate a new immodules cache file.
(mkdir-p (string-append #$output prefix))
(let ((pipe (apply open-pipe* OPEN_READ query modules))
(outfile (string-append #$output prefix
"/immodules-gtk" #$major ".cache")))
(dynamic-wind
(const #t)
(lambda ()
(call-with-output-file outfile
(lambda (out)
(while (not (eof-object? (peek-char pipe)))
(write-char (read-char pipe) out))))
#t)
(lambda ()
(close-pipe pipe)))))))))
;; Don't run the hook when there's nothing to do.
(let ((gexp #~(begin
#$(if gtk+ (build gtk+ "3.0.0") #t)
#$(if gtk+-2 (build gtk+-2 "2.10.0") #t))))
(if (or gtk+ gtk+-2)
(gexp->derivation "gtk-im-modules" gexp
#:local-build? #t
#:substitutable? #f)
(return #f)))))
(define (xdg-desktop-database manifest)
"Return a derivation that builds the @file{mimeinfo.cache} database from
desktop files. It's used to query what applications can handle a given
@ -844,6 +905,7 @@ files for the truetype fonts of the @var{manifest} entries."
ghc-package-cache-file
ca-certificate-bundle
gtk-icon-themes
gtk-im-modules
xdg-desktop-database
xdg-mime-database))