[PATCH] guix: gnu-build-system: add new phase patch-dot-desktop-files

[John Darrington <jmd@gnu.org>]

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)))
 
 \f
-- 
2.10.0