utils: 'wrap-program' produces only one wrapper file.

* guix/build/utils.scm (wrap-program)[wrapper-file-name]
[next-wrapper-number, wrapper-target]: Remove.
[wrapped-file, already-wrapped?]: New variables.
[last-line]: New procedure.
Use it to append to PROG when a wrapper already exists.
* tests/build-utils.scm ("wrap-program, one input, multiple calls"):
Adjust the list of files to delete.

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>
@@ -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
+If PROG has previously been wrapped by 'wrap-program', the wrapper is extended
-the previous wrapper."
+with definitions for VARS."
-  (define (wrapper-file-name number)
+  (define wrapped-file
-    (format #f "~a/.~a-wrap-~2'0d" (dirname prog) (basename prog) number))
+    (string-append (dirname prog) "/." (basename prog) "-real"))
-  (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))
+  (define already-wrapped?
-         (target   (wrapper-target number))
+    (file-exists? wrapped-file))
-         (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
+  (define (last-line port)
-      (lambda ()
+    ;; Return the last line read from PORT and leave PORT's cursor right
-        (format #t
+    ;; before it.
-                "#!~a~%~a~%exec -a \"$0\" \"~a\" \"$@\"~%"
+    (let loop ((previous-line-offset 0)
-                (which "bash")
+               (previous-line "")
-                (string-join (map export-variable vars)
+               (position (seek port 0 SEEK_CUR)))
-                             "\n")
+      (match (read-line port 'concat)
-                (canonicalize-path target))))
+        ((? eof-object?)
+         (seek port previous-line-offset SEEK_SET)
+         previous-line)
+        ((? string? line)
+         (loop position line (+ (string-length line) position))))))
 
-    (chmod prog-tmp #o755)
+  (define (export-variable lst)
-    (rename-file prog-tmp wrapper)
+    ;; Return a string that exports an environment variable.
-    (symlink wrapper prog-tmp)
+    (match lst
-    (rename-file prog-tmp prog)))
+      ((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))))
 
 
 ;;;

tests/build-utils.scm

@@ -118,8 +118,7 @@
        (let* ((pipe (open-input-pipe foo))
               (str  (get-string-all pipe)))
          (with-directory-excursion directory
-           (for-each delete-file
+           (for-each delete-file '("foo" ".foo-real")))
-                     '("foo" ".foo-real" ".foo-wrap-01" ".foo-wrap-02")))
          (and (zero? (close-pipe pipe))
               str))))))