From: John Darrington <j...@gnu.org>
New patch as requested.
* guix/build/gnu-build-system.scm (patch-dot-desktop-files): New procedure.
---
guix/build/gnu-build-system.scm | 46 +++++++++++++++++++++++++++++++++++++++++
1 file changed, 46 insertions(+)
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 93ddc9a..e5d2abf 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -544,6 +544,51 @@ 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
+path names."
+ (define (find-binary binary output-dir inputs)
+ "Search for BINARY first in OUTPUT-DIR, then in the directories
+of INPUTS. INPUTS is an alist where the directories are the cdrs. If no
+suitable BINARY cannot be found return BINARY unchanged."
+
+ ;; Search for BINARY in the output directory,
+ ;; then all the input directories.
+ (let lp ((directories (cons output-dir
+ (map (lambda (input)
+ (match input ((_ . y) y))) inputs))))
+ (if (null? directories)
+ ;; Leave unchanged if we cannot find the binary.
+ binary
+ (let ((resolv (find-files
+ (match directories ((x . _) x))
+ (lambda (file stat)
+ ;; The candidate file must be a regular file,
+ ;; have execute permission and the correct name.
+ (and stat
+ (eq? 'regular (stat:type stat))
+ (not (zero? (logand #o001 (stat:perms
stat))))
+ (string=? (basename file) binary))))))
+
+ (if (null? resolv)
+ (lp (match directories ((_ . y) y)))
+ (match resolv ((x . _) x)))))))
+
+ (for-each (match-lambda
+ (( _ . output-dir)
+ (for-each (lambda (f)
+ (substitute* f
+ (("^Exec=([^/[:blank:]\r\n]*)(.*)$" _ binary
rest)
+ (string-append
+ "Exec=" (find-binary binary output-dir
inputs) rest))
+
+ (("^TryExec=([^/[:blank:]\r\n]*)(.*)$" _ binary
rest)
+ (string-append
+ "TryExec=" (find-binary binary output-dir
inputs) rest))))
+ (find-files output-dir "\\.desktop$"))))
+ outputs) #t)
+
(define %standard-phases
;; Standard build phases, as a list of symbol/procedure pairs.
(let-syntax ((phases (syntax-rules ()
@@ -556,6 +601,7 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
validate-runpath
validate-documentation-location
delete-info-dir-file
+ patch-dot-desktop-files
compress-documentation)))
--
2.10.0
