aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2016-09-07 23:59:02 +0200
committerLudovic Courtès <ludo@gnu.org>2016-09-07 23:59:02 +0200
commitb14a8385095f6672960fb8378c6578acf1ebbf8a (patch)
tree9af192e11499f1195d07cec842f740a8c0f3ade2
parent5c838ec9cd121e7e80587648e3d76347932436c0 (diff)
downloadguix-b14a8385095f6672960fb8378c6578acf1ebbf8a.tar
guix-b14a8385095f6672960fb8378c6578acf1ebbf8a.tar.gz
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.
-rw-r--r--guix/build/utils.scm130
-rw-r--r--tests/build-utils.scm3
2 files changed, 72 insertions, 61 deletions
diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index 6e706b378e..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>
@@ -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/tests/build-utils.scm b/tests/build-utils.scm
index cc59b2eff7..7d49446f66 100644
--- a/tests/build-utils.scm
+++ b/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
- '("foo" ".foo-real" ".foo-wrap-01" ".foo-wrap-02")))
+ (for-each delete-file '("foo" ".foo-real")))
(and (zero? (close-pipe pipe))
str))))))