diff mbox

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

Message ID 1474782201-32677-1-git-send-email-john@darrington.wattle.id.au
State New
Headers show

Commit Message

John Darrington Sept. 25, 2016, 5:43 a.m. UTC 
From: John Darrington <jmd@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(+)

Comments

Ludovic Courtès Oct. 1, 2016, 10:18 a.m. UTC | #1 
John Darrington <john@darrington.wattle.id.au> skribis:

> From: John Darrington <jmd@gnu.org>
>
>
> New patch as requested.
>
>
>
>
> * guix/build/gnu-build-system.scm (patch-dot-desktop-files): New procedure.

I pushed a modified version of this patch as
d31860b9de07810e114490db5cc160a8b078c58d, essentially making it more
concise and adding ‘format’ statements so people have some information
in their build log.

Thanks!

Ludo’.
diff mbox

Patch

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)))