[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/04: build-system/gnu: Add 'patch-dot-desktop-files' phase.
From: |
Ludovic Courtès |
Subject: |
01/04: build-system/gnu: Add 'patch-dot-desktop-files' phase. |
Date: |
Sat, 1 Oct 2016 10:15:57 +0000 (UTC) |
civodul pushed a commit to branch core-updates
in repository guix.
commit d31860b9de07810e114490db5cc160a8b078c58d
Author: John Darrington <address@hidden>
Date: Sun Sep 25 07:43:21 2016 +0200
build-system/gnu: Add 'patch-dot-desktop-files' phase.
* guix/build/gnu-build-system.scm (patch-dot-desktop-files): New
procedure.
(%standard-phases): Add it.
Co-authored-by: Ludovic Courtès <address@hidden>
---
guix/build/gnu-build-system.scm | 42 +++++++++++++++++++++++++++++++++++++++
1 file changed, 42 insertions(+)
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 93ddc9a..1dfd854 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -544,6 +544,47 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
outputs)
#t)
+
+(define* (patch-dot-desktop-files #:key outputs inputs #:allow-other-keys)
+ "Replace any references to executables in '.desktop' files with their
+absolute file names."
+ (define bin-directories
+ (append-map (match-lambda
+ ((_ . directory)
+ (list (string-append directory "/bin")
+ (string-append directory "/sbin"))))
+ outputs))
+
+ (define (which program)
+ (or (search-path bin-directories program)
+ (begin
+ (format (current-error-port)
+ "warning: '.desktop' file refers to '~a', \
+which cannot be found~%"
+ program)
+ program)))
+
+ (for-each (match-lambda
+ ((_ . directory)
+ (let ((applications (string-append directory
+ "/share/applications")))
+ (when (directory-exists? applications)
+ (let ((files (find-files applications "\\.desktop$")))
+ (format #t "adjusting ~a '.desktop' files in ~s~%"
+ (length files) applications)
+
+ ;; '.desktop' files contain translations and are always
+ ;; UTF-8-encoded.
+ (with-fluids ((%default-port-encoding "UTF-8"))
+ (substitute* files
+ (("^Exec=([^/[:blank:]\r\n]*)(.*)$" _ binary rest)
+ (string-append "Exec=" (which binary) rest))
+ (("^TryExec=([^/[:blank:]\r\n]*)(.*)$" _ binary rest)
+ (string-append "TryExec="
+ (which binary) rest)))))))))
+ outputs)
+ #t)
+
(define %standard-phases
;; Standard build phases, as a list of symbol/procedure pairs.
(let-syntax ((phases (syntax-rules ()
@@ -556,6 +597,7 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
validate-runpath
validate-documentation-location
delete-info-dir-file
+ patch-dot-desktop-files
compress-documentation)))