From 0c84fdb879c78a129c9d77bcdf9a5e3135825ad9 Mon Sep 17 00:00:00 2001
From: Nikita Karetnikov <address@hidden>
Date: Thu, 28 Feb 2013 20:27:36 +0000
Subject: [PATCH] utils: Add 'wrap-program'.

* guix/build/utils.scm (wrap-program): New procedure.
---
 guix/build/utils.scm |   41 ++++++++++++++++++++++++++++++++++++++++-
 1 files changed, 40 insertions(+), 1 deletions(-)

diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index 6921e31..63012f0 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -49,7 +49,8 @@
             patch-shebang
             patch-makefile-SHELL
             fold-port-matches
-            remove-store-references))
+            remove-store-references
+            wrap-program))
 

 ;;;
@@ -605,6 +606,44 @@ known as `nuke-refs' in Nixpkgs."
                              (put-u8 out (char->integer char))
                              result))))))
 
+(define (wrap-program prog varlst)
+  "Copy PROG to .PROG-real and make PROG a wrapper."
+  (define (export-envvar lst)
+    ;; Return a string that exports an environment variable.
+    (define (separate lst delim)
+      ;; Return a string of directories separated by DELIM.
+      (fold-right (lambda (x acc)
+                    (if (string-null? acc)
+                        x
+                        (string-append x delim acc)))
+                  ""
+                  lst))
+
+    ;; TODO: Make SEP optional.
+    (match lst
+           ((var sep '= rest)
+            (format #f "export ~a=\"~a\""
+                    var (separate rest sep)))
+
+           ((var sep 'prefix rest)
+            (format #f "export ~a=\"~a~a${~a~a+~a}$~a\""
+                    var (separate rest sep) sep var sep sep var))
+
+           ((var sep 'suffix rest)
+            (format #f "export ~a=\"$~a${~a~a+~a}~a~a\""
+                    var var var sep sep sep (separate rest sep)))))
+
+  ;; XXX: Use an absolute filename; remove '-real'.
+  (format #f "#!~a~%~aexec ./.~a-real~%"
+          (which "bash")
+
+          (fold-right (lambda (x acc)
+                        (string-append x "\n" acc))
+                      ""
+                      (map export-envvar varlst))
+
+          prog)) ; XXX: use a real program instead
+
 ;;; Local Variables:
 ;;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1)
 ;;; eval: (put 'with-throw-handler 'scheme-indent-function 1)
-- 
1.7.5.4