[bug#29951] [PATCH] WIP guix: Add wrap-script.

[Ricardo Wurmus]

* guix/build/utils.scm (wrap-script): New procedure.
---
 guix/build/utils.scm | 101 +++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 101 insertions(+)

diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index 7391307c8..a2efcb31c 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2013 Andreas Enge <address@hidden>
 ;;; Copyright © 2013 Nikita Karetnikov <address@hidden>
 ;;; Copyright © 2015 Mark H Weaver <address@hidden>
+;;; Copyright © 2018 Ricardo Wurmus <address@hidden>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -84,6 +85,7 @@
             fold-port-matches
             remove-store-references
             wrap-program
+            wrap-script
             invoke
 
             locale-category->string))
@@ -1068,6 +1070,105 @@ with definitions for VARS."
         (chmod prog-tmp #o755)
         (rename-file prog-tmp prog))))
 
+(define wrap-script
+  (let ((interpreter-regex
+         (make-regexp
+          (string-append "^#! ?(/bin/sh|/gnu/store/[^/]+/bin/("
+                         (string-join '("python[^ ]*"
+                                        "Rscript"
+                                        "perl"
+                                        "ruby"
+                                        "bash"
+                                        "sh") "|")
+                         ") ?.*)")))
+        (coding-line-regex
+         (make-regexp
+          ".*#.*coding[=:][[:space:]]*([-[a-zA-Z_0-9].]+)")))
+    (lambda* (prog #:rest vars)
+      "Wrap the script PROG such that VARS are set first.  The format of VARS
+is the same as in the WRAP-PROGRAM procedure.  This procedure differs from
+WRAP-PROGRAM in that it does not create a separate shell script.  Instead,
+PROG is modified directly by prepending a Guile script, which is interpreted
+as a comment in the script's language.
+
+Special encoding comments as supported by Python are recreated on the second
+line.
+
+Note that this procedure can only be used once per file as Guile scripts are
+not supported."
+      (define update-env
+        (match-lambda
+          ((var sep '= rest)
+           `(setenv ,var ,(string-join rest sep)))
+          ((var sep 'prefix rest)
+           `(let ((current (getenv ,var)))
+              (setenv ,var (if current
+                               (string-append ,(string-join rest sep)
+                                              ,sep current)
+                               ,(string-join rest sep)))))
+          ((var sep 'suffix rest)
+           `(let ((current (getenv ,var)))
+              (setenv ,var (if current
+                               (string-append current ,sep
+                                              ,(string-join rest sep))
+                               ,(string-join rest sep)))))
+          ((var '= rest)
+           `(setenv ,var ,(string-join rest ":")))
+          ((var 'prefix rest)
+           `(let ((current (getenv ,var)))
+              (setenv ,var (if current
+                               (string-append ,(string-join rest ":")
+                                              ":" current)
+                               ,(string-join rest ":")))))
+          ((var 'suffix rest)
+           `(let ((current (getenv ,var)))
+              (setenv ,var (if current
+                               (string-append current ":"
+                                              ,(string-join rest ":"))
+                               ,(string-join rest ":")))))))
+      (let-values (((interpreter coding-line)
+                    (call-with-ascii-input-file prog
+                      (lambda (p)
+                        (values (false-if-exception
+                                 (and=> (regexp-exec interpreter-regex 
(read-line p))
+                                        (lambda (m) (match:substring m 1))))
+                                (false-if-exception
+                                 (and=> (regexp-exec coding-line-regex 
(read-line p))
+                                        (lambda (m) (match:substring m 
0)))))))))
+        (when interpreter
+          (let* ((header (format #f "\
+#!~a --no-auto-compile
+#!#; ~a
+#\\-~s
+#\\-~s
+"
+                                 (which "guile")
+                                 (or coding-line "Guix wrapper")
+                                 (cons 'begin (map update-env vars))
+                                 `(apply execl ,interpreter
+                                         (car (command-line))
+                                         (command-line))))
+                 (template (string-append prog ".XXXXXX"))
+                 (out      (mkstemp! template))
+                 (st       (stat prog))
+                 (mode     (stat:mode st)))
+            (with-throw-handler #t
+              (lambda ()
+                (call-with-ascii-input-file prog
+                  (lambda (p)
+                    (format out header)
+                    (dump-port p out)
+                    (close out)
+                    (chmod template mode)
+                    (rename-file template prog)
+                    (set-file-time prog st))))
+              (lambda (key . args)
+                (format (current-error-port)
+                        "wrap-script: ~a: error: ~a ~s~%"
+                        prog key args)
+                (false-if-exception (delete-file template))
+                #f))))))))
+
 
 ;;;
 ;;; Locales.
-- 
2.15.0