utils: Add `patch-shebang'.

* guix/build/utils.scm (search-path-as-string->list): New procedure.
  (dump-port, patch-shebang): New procedures.

1 files changed, 76 insertions, 1 deletions

diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index e99afdfcf3..fbffa8ba43 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -22,14 +22,20 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 rdelim)
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports)
   #:export (directory-exists?
             with-directory-excursion
             set-path-environment-variable
+            search-path-as-string->list
+            list->search-path-as-string
             alist-cons-before
             alist-cons-after
             alist-replace
             substitute
-            substitute*))
+            substitute*
+            dump-port
+            patch-shebang))
 
 
 ;;;
@@ -80,6 +86,9 @@ INPUT-DIRS.  Example:
 (define (list->search-path-as-string lst separator)
   (string-join lst separator))
 
+(define* (search-path-as-string->list path #:optional (separator #\:))
+  (string-tokenize path (char-set-complement (char-set separator))))
+
 (define* (set-path-environment-variable env-var sub-directories input-dirs
                                         #:key (separator ":"))
   "Look for each of SUB-DIRECTORIES in INPUT-DIRS.  Set ENV-VAR to a
@@ -228,6 +237,72 @@ match substring."
                                          (display (begin body ...) p))))
                     ...)))
 
+
+;;;
+;;; Patching shebangs---e.g., /bin/sh -> /nix/store/xyz...-bash/bin/sh.
+;;;
+
+(define (dump-port in out)
+  "Read as much data as possible from IN and write it to OUT."
+  (define buffer-size 4096)
+  (define buffer
+    (make-bytevector buffer-size))
+
+  (let loop ((bytes (get-bytevector-n! in buffer 0 buffer-size)))
+    (or (eof-object? bytes)
+        (begin
+          (put-bytevector out buffer 0 bytes)
+          (loop (get-bytevector-n! in buffer 0 buffer-size))))))
+
+(define patch-shebang
+  (let ((shebang-rx (make-regexp "^[[:blank:]]*([[:graph:]]*)/([[:alnum:]]+)(.*)$")))
+    (lambda (file)
+      "Patch the #! interpreter path in FILE, if FILE actually starts with a
+shebang."
+      (define (patch p interpreter rest-of-line)
+        (let* ((template (string-append file ".XXXXXX"))
+               (out      (mkstemp! template))
+               (mode     (stat:mode (stat file))))
+          (with-throw-handler #t
+            (lambda ()
+              (format out "#!~a~a~%"
+                      interpreter rest-of-line)
+              (dump-port p out)
+              (close out)
+              (chmod template mode)
+              (rename-file template file)
+              #t)
+            (lambda (key . args)
+              (format (current-error-port)
+                      "patch-shebang: ~a: error: ~a ~s~%"
+                      file key args)
+              (false-if-exception (delete-file template))
+              #f))))
+
+      (with-fluids ((%default-port-encoding #f))  ; ASCII
+        (call-with-input-file file
+          (lambda (p)
+            (and (eq? #\# (read-char p))
+                 (eq? #\! (read-char p))
+                 (let ((line (false-if-exception (read-line p))))
+                   (and=> (and line (regexp-exec shebang-rx line))
+                          (lambda (m)
+                            (let* ((PATH
+                                    (search-path-as-string->list (getenv "PATH")))
+                                   (cmd (match:substring m 2))
+                                   (bin (search-path PATH cmd)))
+                              (if bin
+                                  (begin
+                                    (format (current-error-port)
+                                            "patch-shebang: ~a: changing `~a/~a' to `~a'~%"
+                                            file (match:substring m 1)
+                                            cmd bin)
+                                    (patch p bin (match:substring m 3)))
+                                  (begin
+                                    (format (current-error-port)
+                                            "patch-shebang: ~a: warning: no binary for interpreter `~a' found in $PATH~%"
+                                            file cmd)
+                                    #f)))))))))))))
 
 ;;; Local Variables:
 ;;; eval: (put 'call-with-output-file/atomic 'scheme-indent-function 1)