diff mbox

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

Message ID 1474389194-7986-1-git-send-email-jmd@gnu.org
State New
Headers show

Commit Message

John Darrington Sept. 20, 2016, 4:33 p.m. UTC
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(+)

Comments

Ludovic Courtès Sept. 24, 2016, 5:15 a.m. UTC | #1
Hello!

John Darrington <jmd@gnu.org> skribis:

> Ludo wanted something like this, I think.  To be pushed to core-updates of course...

This Ludo is a very demanding person…  ;-)

> * guix/build/gnu-build-system.scm (patch-dot-desktop-files): New procedure.

The approach looks good to me, so I’m just commenting on the style:

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

Please use ‘match’ instead of car, cdr, etc. (see ‘patch-shebangs’ in
the same file for an example), and use full words such as “directories”
instead of “dir-list” (info "(guix) Coding Style").

I think you can write:

  (string=? binary file)

instead of using ‘file-name-predicate’.

> +    (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$"))))

The ‘find-files’ regexp should be "\\.desktop$", or a predicate:

  (lambda (file stat)
    (string-suffix? ".desktop" file))

Could you send an updated patch?

Thanks for working on it!

Ludo’.
diff mbox

Patch

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