Merge branch 'core-updates'

5 files changed, 165 insertions, 104 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/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 20f08027da..78392c9a11 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -483,13 +483,16 @@ elpa.gnu.org, and all the GNOME packages."
     (let-values (((name version) (package-name->name+version file)))
       (even-minor-version? (or version name))))
 
+  (define upstream-name
+    ;; Some packages like "NetworkManager" have camel-case names.
+    (or (assoc-ref (package-properties package) 'upstream-name)
+        (package-name package)))
+
   (false-if-ftp-error
-   (latest-ftp-release (package-name package)
+   (latest-ftp-release upstream-name
                        #:server "ftp.gnome.org"
                        #:directory (string-append "/pub/gnome/sources/"
-                                                  (match (package-name package)
-                                                    ("gconf" "GConf")
-                                                    (x       x)))
+                                                  upstream-name)
 
 
                        ;; <https://www.gnome.org/gnome-3/source/> explains
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 33a5f50a53..b56b8f4c79 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -682,7 +682,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)
@@ -699,9 +710,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"))
@@ -716,11 +725,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)