ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-11-07 23:46:13 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

build-system/gnu: Add 'patch-dot-desktop-files' phase.

Browse source 
* 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>
This commit is contained in:
John Darrington 2016-09-25 07:43:21 +02:00 committed by Ludovic Courtès
parent c573f5a5a5
commit d31860b9de
No known key found for this signature in database
GPG key ID: 090B11993D9AEBB5
1 changed files with 42 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

42
guix/build/gnu-build-system.scm
View file

@ -544,6 +544,47 @@ (define* (delete-info-dir-file #:key outputs #:allow-other-keys)
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 @@ (define %standard-phases
validate-runpath
validate-documentation-location
delete-info-dir-file
patch-dot-desktop-files
compress-documentation)))