From d31860b9de07810e114490db5cc160a8b078c58d Mon Sep 17 00:00:00 2001
From: John Darrington <jmd@gnu.org>
Date: Sun, 25 Sep 2016 07:43:21 +0200
Subject: build-system/gnu: Add 'patch-dot-desktop-files' phase.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

* guix/build/gnu-build-system.scm (patch-dot-desktop-files): New
procedure.
(%standard-phases): Add it.

Co-authored-by: Ludovic Courtès <ludo@gnu.org>
---
 guix/build/gnu-build-system.scm | 42 +++++++++++++++++++++++++++++++++++++++++
 1 file changed, 42 insertions(+)

(limited to 'guix/build')

diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 93ddc9abc8..1dfd85450c 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -544,6 +544,47 @@ 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 file names."
+  (define bin-directories
+    (append-map (match-lambda
+                  ((_ . directory)
+                   (list (string-append directory "/bin")
+                         (string-append directory "/sbin"))))
+                outputs))
+
+  (define (which program)
+    (or (search-path bin-directories program)
+        (begin
+          (format (current-error-port)
+                  "warning: '.desktop' file refers to '~a', \
+which cannot be found~%"
+                  program)
+          program)))
+
+  (for-each (match-lambda
+              ((_ . directory)
+               (let ((applications (string-append directory
+                                                  "/share/applications")))
+                 (when (directory-exists? applications)
+                   (let ((files (find-files applications "\\.desktop$")))
+                     (format #t "adjusting ~a '.desktop' files in ~s~%"
+                             (length files) applications)
+
+                     ;; '.desktop' files contain translations and are always
+                     ;; UTF-8-encoded.
+                     (with-fluids ((%default-port-encoding "UTF-8"))
+                       (substitute* files
+                         (("^Exec=([^/[:blank:]\r\n]*)(.*)$" _ binary rest)
+                          (string-append "Exec=" (which binary) rest))
+                         (("^TryExec=([^/[:blank:]\r\n]*)(.*)$" _ binary rest)
+                          (string-append "TryExec="
+                                         (which binary) rest)))))))))
+            outputs)
+  #t)
+
 (define %standard-phases
   ;; Standard build phases, as a list of symbol/procedure pairs.
   (let-syntax ((phases (syntax-rules ()
@@ -556,6 +597,7 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
             validate-runpath
             validate-documentation-location
             delete-info-dir-file
+            patch-dot-desktop-files
             compress-documentation)))
 
 
-- 
cgit v1.2.3