Ludo wanted something like this, I think. To be pushed to core-updates of
course...
* guix/build/gnu-build-system.scm (patch-dot-desktop-files): New procedure.
---
guix/build/gnu-build-system.scm | 45 +++++++++++++++++++++++++++++++++++++++++
1 file changed, 45 insertions(+)
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 34edff7..ebd0f7b 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -552,6 +552,50 @@ 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 ((dir-list (cons output-dir (map (lambda (i) (cdr i)) inputs))))
+ (if (null? dir-list)
+ ;; Leave unchanged if we cannot find the binary.
+ binary
+ (let ((resolv (find-files
+ (car dir-list)
+ (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))))
+ ((file-name-predicate
+ (string-append "^" binary "$")) file
stat))))))
+
+ (if (null? resolv)
+ (lp (cdr dir-list))
+ (car resolv))))))
+
+ (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 ()
@@ -564,6 +608,7 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
validate-runpath
validate-documentation-location
delete-info-dir-file
+ patch-dot-desktop-files
compress-documentation)))
--
2.10.0
