From: John Darrington <john@darrington.wattle.id.au>
To: guix-devel@gnu.org
Cc: John Darrington <jmd@gnu.org>
Subject: [PATCH] guix: gnu-build-system: add new phase patch-dot-desktop-files
Date: Sun, 25 Sep 2016 07:43:21 +0200 [thread overview]
Message-ID: <1474782201-32677-1-git-send-email-john@darrington.wattle.id.au> (raw)
In-Reply-To: <87twd5q3oe.fsf@gnu.org>
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(+)
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)))
\f
--
2.10.0
next prev parent reply other threads:[~2016-09-25 5:43 UTC|newest]
Thread overview: 19+ messages / expand[flat|nested] mbox.gz Atom feed top
2016-09-12 3:01 [PATCH] Adding .xsession to guile-wm Alex ter Weele
2016-09-12 15:40 ` Thompson, David
2016-09-12 15:56 ` Alex ter Weele
2016-09-12 15:59 ` Thompson, David
2016-09-12 16:05 ` John Darrington
2016-09-12 18:07 ` Efraim Flashner
2016-09-12 18:13 ` John Darrington
2016-09-13 1:23 ` Alex ter Weele
2016-09-13 1:45 ` Thompson, David
2016-09-13 4:27 ` John Darrington
2016-09-13 11:52 ` Ludovic Courtès
2016-09-20 16:33 ` [PATCH] guix: gnu-build-system: add new phase patch-dot-desktop-files John Darrington
2016-09-24 5:15 ` Ludovic Courtès
2016-09-25 5:43 ` John Darrington [this message]
2016-10-01 10:18 ` Ludovic Courtès
2016-09-13 11:51 ` [PATCH] Adding .xsession to guile-wm Ludovic Courtès
2016-09-13 12:04 ` Ludovic Courtès
2016-09-14 1:40 ` Alex ter Weele
2016-09-14 14:45 ` Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=1474782201-32677-1-git-send-email-john@darrington.wattle.id.au \
--to=john@darrington.wattle.id.au \
--cc=guix-devel@gnu.org \
--cc=jmd@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).