summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/build/gnu-build-system.scm96
-rw-r--r--guix/build/utils.scm134
-rw-r--r--guix/packages.scm7
-rw-r--r--guix/profiles.scm21
4 files changed, 158 insertions, 100 deletions
diff --git a/guix/build/gnu-build-system.scm b/guix/build/gnu-build-system.scm
index 34edff7f40..1dfd85450c 100644
--- a/guix/build/gnu-build-system.scm
+++ b/guix/build/gnu-build-system.scm
@@ -172,22 +172,23 @@ files such as `.in' templates. Most scripts honor $SHELL and
$CONFIG_SHELL, but some don't, such as `mkinstalldirs' or Automake's
`missing' script."
(for-each patch-shebang
- (remove (lambda (file)
- (or (not (file-exists? file)) ;dangling symlink
- (file-is-directory? file)))
- (find-files "."))))
+ (find-files "."
+ (lambda (file stat)
+ ;; Filter out symlinks.
+ (eq? 'regular (stat:type stat)))
+ #:stat lstat)))
(define (patch-generated-file-shebangs . rest)
"Patch shebangs in generated files, including `SHELL' variables in
makefiles."
- ;; Patch executable files, some of which might have been generated by
- ;; `configure'.
+ ;; Patch executable regular files, some of which might have been generated
+ ;; by `configure'.
(for-each patch-shebang
- (filter (lambda (file)
- (and (file-exists? file)
- (executable-file? file)
- (not (file-is-directory? file))))
- (find-files ".")))
+ (find-files "."
+ (lambda (file stat)
+ (and (eq? 'regular (stat:type stat))
+ (not (zero? (logand (stat:mode stat) #o100)))))
+ #:stat lstat))
;; Patch `SHELL' in generated makefiles.
(for-each patch-makefile-SHELL (find-files "." "^(GNU)?[mM]akefile$")))
@@ -386,26 +387,17 @@ makefiles."
(when debug-output
(format #t "debugging output written to ~s using ~s~%"
debug-output objcopy-command))
- (file-system-fold (const #t)
- (lambda (path stat result) ; leaf
- (and (file-exists? path) ;discard dangling symlinks
- (or (elf-file? path) (ar-file? path))
- (or (not debug-output)
- (make-debug-file path))
- (zero? (apply system* strip-command
- (append strip-flags (list path))))
- (or (not debug-output)
- (add-debug-link path))))
- (const #t) ; down
- (const #t) ; up
- (const #t) ; skip
- (lambda (path stat errno result)
- (format (current-error-port)
- "strip: failed to access `~a': ~a~%"
- path (strerror errno))
- #f)
- #t
- dir))
+
+ (for-each (lambda (file)
+ (and (file-exists? file) ;discard dangling symlinks
+ (or (elf-file? file) (ar-file? file))
+ (or (not debug-output)
+ (make-debug-file file))
+ (zero? (apply system* strip-command
+ (append strip-flags (list file))))
+ (or (not debug-output)
+ (add-debug-link file))))
+ (find-files dir)))
(or (not strip-binaries?)
(every strip-dir
@@ -552,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 ()
@@ -564,6 +597,7 @@ DOCUMENTATION-COMPRESSOR-FLAGS."
validate-runpath
validate-documentation-location
delete-info-dir-file
+ patch-dot-desktop-files
compress-documentation)))
diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index 2988193fce..bc6f114152 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
@@ -518,8 +518,8 @@ following forms:
(add-before <old-phase-name> <new-phase-name> <new-phase>)
(add-after <old-phase-name> <new-phase-name> <new-phase>)
-Where every <*-phase-name> is an automatically quoted symbol, and <new-phase>
-an expression evaluating to a procedure."
+Where every <*-phase-name> is an expression evaluating to a symbol, and
+<new-phase> an expression evaluating to a procedure."
(let* ((phases* phases)
(phases* (%modify-phases phases* mod-spec))
...)
@@ -944,64 +944,76 @@ This is useful for scripts that expect particular programs to be in $PATH, for
programs that expect particular shared libraries to be in $LD_LIBRARY_PATH, or
modules in $GUILE_LOAD_PATH, etc.
-If PROG has previously been wrapped by wrap-program the wrapper will point to
-the previous wrapper."
- (define (wrapper-file-name number)
- (format #f "~a/.~a-wrap-~2'0d" (dirname prog) (basename prog) number))
- (define (next-wrapper-number)
- (let ((wrappers
- (find-files (dirname prog)
- (string-append "\\." (basename prog) "-wrap-.*"))))
- (if (null? wrappers)
- 0
- (string->number (string-take-right (last wrappers) 2)))))
- (define (wrapper-target number)
- (if (zero? number)
- (let ((prog-real (string-append (dirname prog) "/."
- (basename prog) "-real")))
- (rename-file prog prog-real)
- prog-real)
- (wrapper-file-name number)))
-
- (let* ((number (next-wrapper-number))
- (target (wrapper-target number))
- (wrapper (wrapper-file-name (1+ number)))
- (prog-tmp (string-append target "-tmp")))
- (define (export-variable lst)
- ;; Return a string that exports an environment variable.
- (match lst
- ((var sep '= rest)
- (format #f "export ~a=\"~a\""
- var (string-join rest sep)))
- ((var sep 'prefix rest)
- (format #f "export ~a=\"~a${~a~a+~a}$~a\""
- var (string-join rest sep) var sep sep var))
- ((var sep 'suffix rest)
- (format #f "export ~a=\"$~a${~a~a+~a}~a\""
- var var var sep sep (string-join rest sep)))
- ((var '= rest)
- (format #f "export ~a=\"~a\""
- var (string-join rest ":")))
- ((var 'prefix rest)
- (format #f "export ~a=\"~a${~a:+:}$~a\""
- var (string-join rest ":") var var))
- ((var 'suffix rest)
- (format #f "export ~a=\"$~a${~a:+:}~a\""
- var var var (string-join rest ":")))))
-
- (with-output-to-file prog-tmp
- (lambda ()
- (format #t
- "#!~a~%~a~%exec -a \"$0\" \"~a\" \"$@\"~%"
- (which "bash")
- (string-join (map export-variable vars)
- "\n")
- (canonicalize-path target))))
-
- (chmod prog-tmp #o755)
- (rename-file prog-tmp wrapper)
- (symlink wrapper prog-tmp)
- (rename-file prog-tmp prog)))
+If PROG has previously been wrapped by 'wrap-program', the wrapper is extended
+with definitions for VARS."
+ (define wrapped-file
+ (string-append (dirname prog) "/." (basename prog) "-real"))
+
+ (define already-wrapped?
+ (file-exists? wrapped-file))
+
+ (define (last-line port)
+ ;; Return the last line read from PORT and leave PORT's cursor right
+ ;; before it.
+ (let loop ((previous-line-offset 0)
+ (previous-line "")
+ (position (seek port 0 SEEK_CUR)))
+ (match (read-line port 'concat)
+ ((? eof-object?)
+ (seek port previous-line-offset SEEK_SET)
+ previous-line)
+ ((? string? line)
+ (loop position line (+ (string-length line) position))))))
+
+ (define (export-variable lst)
+ ;; Return a string that exports an environment variable.
+ (match lst
+ ((var sep '= rest)
+ (format #f "export ~a=\"~a\""
+ var (string-join rest sep)))
+ ((var sep 'prefix rest)
+ (format #f "export ~a=\"~a${~a~a+~a}$~a\""
+ var (string-join rest sep) var sep sep var))
+ ((var sep 'suffix rest)
+ (format #f "export ~a=\"$~a${~a~a+~a}~a\""
+ var var var sep sep (string-join rest sep)))
+ ((var '= rest)
+ (format #f "export ~a=\"~a\""
+ var (string-join rest ":")))
+ ((var 'prefix rest)
+ (format #f "export ~a=\"~a${~a:+:}$~a\""
+ var (string-join rest ":") var var))
+ ((var 'suffix rest)
+ (format #f "export ~a=\"$~a${~a:+:}~a\""
+ var var var (string-join rest ":")))))
+
+ (if already-wrapped?
+
+ ;; PROG is already a wrapper: add the new "export VAR=VALUE" lines just
+ ;; before the last line.
+ (let* ((port (open-file prog "r+"))
+ (last (last-line port)))
+ (for-each (lambda (var)
+ (display (export-variable var) port)
+ (newline port))
+ vars)
+ (display last port)
+ (close-port port))
+
+ ;; PROG is not wrapped yet: create a shell script that sets VARS.
+ (let ((prog-tmp (string-append wrapped-file "-tmp")))
+ (link prog wrapped-file)
+
+ (call-with-output-file prog-tmp
+ (lambda (port)
+ (format port
+ "#!~a~%~a~%exec -a \"$0\" \"~a\" \"$@\"~%"
+ (which "bash")
+ (string-join (map export-variable vars) "\n")
+ (canonicalize-path wrapped-file))))
+
+ (chmod prog-tmp #o755)
+ (rename-file prog-tmp prog))))
;;;
diff --git a/guix/packages.scm b/guix/packages.scm
index a3fab4dc13..beb958f156 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2014, 2015 Mark H Weaver <mhw@netris.org>
;;; Copyright © 2015 Eric Bavier <bavier@member.fsf.org>
+;;; Copyright © 2016 Alex Kost <alezost@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -493,9 +494,11 @@ specifies modules in scope when evaluating SNIPPET."
(format (current-error-port) "applying '~a'...~%" patch)
;; Use '--force' so that patches that do not apply perfectly are
- ;; rejected.
+ ;; rejected. Use '--no-backup-if-mismatch' to prevent making
+ ;; "*.orig" file if a patch is applied with offset.
(zero? (system* (string-append #+patch "/bin/patch")
- "--force" #+@flags "--input" patch)))
+ "--force" "--no-backup-if-mismatch"
+ #+@flags "--input" patch)))
(define (first-file directory)
;; Return the name of the first file in DIRECTORY.
diff --git a/guix/profiles.scm b/guix/profiles.scm
index e7319a8a10..d162f6241b 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -680,7 +680,18 @@ MANIFEST. Single-file bundles are required by programs such as Git and Lynx."
(define (gtk-icon-themes manifest)
"Return a derivation that unions all icon themes from manifest entries and
creates the GTK+ 'icon-theme.cache' file for each theme."
- (mlet %store-monad ((gtk+ (manifest-lookup-package manifest "gtk+")))
+ (define gtk+ ; lazy reference
+ (module-ref (resolve-interface '(gnu packages gtk)) 'gtk+))
+
+ (mlet %store-monad ((%gtk+ (manifest-lookup-package manifest "gtk+"))
+ ;; XXX: Can't use gtk-update-icon-cache corresponding
+ ;; to the gtk+ referenced by 'manifest'. Because
+ ;; '%gtk+' can be either a package or store path, and
+ ;; there's no way to get the "bin" output for the later.
+ (gtk-update-icon-cache
+ -> #~(string-append #+gtk+:bin
+ "/bin/gtk-update-icon-cache")))
+
(define build
(with-imported-modules '((guix build utils)
(guix build union)
@@ -697,9 +708,7 @@ creates the GTK+ 'icon-theme.cache' file for each theme."
(let* ((destdir (string-append #$output "/share/icons"))
(icondirs (filter file-exists?
(map (cut string-append <> "/share/icons")
- '#$(manifest-inputs manifest))))
- (update-icon-cache (string-append
- #+gtk+ "/bin/gtk-update-icon-cache")))
+ '#$(manifest-inputs manifest)))))
;; Union all the icons.
(mkdir-p (string-append #$output "/share"))
@@ -714,11 +723,11 @@ creates the GTK+ 'icon-theme.cache' file for each theme."
;; "abiword_48.png". Ignore these.
(when (file-is-directory? dir)
(ensure-writable-directory dir)
- (system* update-icon-cache "-t" dir "--quiet"))))
+ (system* #+gtk-update-icon-cache "-t" dir "--quiet"))))
(scandir destdir (negate (cut member <> '("." "..")))))))))
;; Don't run the hook when there's nothing to do.
- (if gtk+
+ (if %gtk+
(gexp->derivation "gtk-icon-themes" build
#:local-build? #t
#:substitutable? #f)