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

[John Darrington]

From: John Darrington <address@hidden>


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