From mboxrd@z Thu Jan 1 00:00:00 1970 From: John Darrington Subject: [PATCH] guix: gnu-build-system: add new phase patch-dot-desktop-files Date: Tue, 20 Sep 2016 18:33:14 +0200 Message-ID: <1474389194-7986-1-git-send-email-jmd@gnu.org> References: <87wpig584u.fsf@gnu.org> Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:60929) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1bmNz8-0001Cc-AW for guix-devel@gnu.org; Tue, 20 Sep 2016 12:33:31 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1bmNz5-0005OQ-4t for guix-devel@gnu.org; Tue, 20 Sep 2016 12:33:30 -0400 In-Reply-To: <87wpig584u.fsf@gnu.org> List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: "Guix-devel" To: guix-devel@gnu.org Cc: John Darrington 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(+) 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))) -- 2.10.0