[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/02: guix: Add wrap-script.
|
From: |
guix-commits |
|
Subject: |
01/02: guix: Add wrap-script. |
|
Date: |
Fri, 8 Feb 2019 04:43:57 -0500 (EST) |
rekado pushed a commit to branch core-updates
in repository guix.
commit 0fb9a8df429a7b9f40610ff15baaff0d8e31e8cf
Author: Ricardo Wurmus <address@hidden>
Date: Tue Jan 2 21:43:07 2018 +0100
guix: Add wrap-script.
* guix/build/utils.scm (wrap-script): New procedure.
(&wrap-error): New condition.
(wrap-error?, wrap-error-program, wrap-error-type): New procedures.
* tests/build-utils.scm ("wrap-script, simple case", "wrap-script, with
encoding declaration", "wrap-script, raises condition"): New tests.
---
guix/build/utils.scm | 125 ++++++++++++++++++++++++++++++++++++++++++++++++++
tests/build-utils.scm | 102 ++++++++++++++++++++++++++++++++++++++++
2 files changed, 227 insertions(+)
diff --git a/guix/build/utils.scm b/guix/build/utils.scm
index 55d34b6..b7cd748 100644
--- a/guix/build/utils.scm
+++ b/guix/build/utils.scm
@@ -4,6 +4,7 @@
;;; Copyright © 2013 Nikita Karetnikov <address@hidden>
;;; Copyright © 2015, 2018 Mark H Weaver <address@hidden>
;;; Copyright © 2018 Arun Isaac <address@hidden>
+;;; Copyright © 2018, 2019 Ricardo Wurmus <address@hidden>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -90,6 +91,11 @@
remove-store-references
wrapper?
wrap-program
+ wrap-script
+
+ wrap-error?
+ wrap-error-program
+ wrap-error-type
invoke
invoke-error?
@@ -1042,6 +1048,11 @@ known as `nuke-refs' in Nixpkgs."
(put-u8 out (char->integer char))
result))))))
+(define-condition-type &wrap-error &error
+ wrap-error?
+ (program wrap-error-program)
+ (type wrap-error-type))
+
(define (wrapper? prog)
"Return #t if PROG is a wrapper as produced by 'wrap-program'."
(and (file-exists? prog)
@@ -1146,6 +1157,120 @@ with definitions for VARS."
(chmod prog-tmp #o755)
(rename-file prog-tmp prog))))
+(define wrap-script
+ (let ((interpreter-regex
+ (make-regexp
+ (string-append "^#! ?(/[^ ]+/bin/("
+ (string-join '("python[^ ]*"
+ "Rscript"
+ "perl"
+ "ruby"
+ "bash"
+ "sh") "|")
+ "))( ?.*)")))
+ (coding-line-regex
+ (make-regexp
+ ".*#.*coding[=:][[:space:]]*([-a-zA-Z_0-9.]+)")))
+ (lambda* (prog #:key (guile (which "guile")) #: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 args coding-line)
+ (call-with-ascii-input-file prog
+ (lambda (p)
+ (let ((first-match
+ (false-if-exception
+ (regexp-exec interpreter-regex (read-line
p)))))
+ (values (and first-match (match:substring
first-match 1))
+ (and first-match (match:substring
first-match 3))
+ (false-if-exception
+ (and=> (regexp-exec coding-line-regex
(read-line p))
+ (lambda (m) (match:substring m
0))))))))))
+ (if interpreter
+ (let* ((header (format #f "\
+#!~a --no-auto-compile
+#!#; ~a
+#\\-~s
+#\\-~s
+"
+ guile
+ (or coding-line "Guix wrapper")
+ (cons 'begin (map update-env
+ (match vars
+ ((#:guile _ . vars)
vars)
+ (_ vars))))
+ `(let ((cl (command-line)))
+ (apply execl ,interpreter
+ (car cl)
+ (cons (car cl)
+ (append
+ ',(string-split args
#\space)
+ cl))))))
+ (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))
+ (raise (condition
+ (&wrap-error (program prog)
+ (type key))))
+ #f)))
+ (raise (condition
+ (&wrap-error (program prog)
+ (type 'no-interpreter-found)))))))))
+
;;;
;;; Locales.
diff --git a/tests/build-utils.scm b/tests/build-utils.scm
index 7d49446..1c90845 100644
--- a/tests/build-utils.scm
+++ b/tests/build-utils.scm
@@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2015, 2016 Ludovic Courtès <address@hidden>
+;;; Copyright © 2019 Ricardo Wurmus <address@hidden>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -122,4 +123,105 @@
(and (zero? (close-pipe pipe))
str))))))
+(let ((script-contents "\
+#!/anything/cabbage-bash-1.2.3/bin/sh
+
+echo hello world"))
+
+ (test-equal "wrap-script, simple case"
+ (string-append
+ (format #f "\
+#!GUILE --no-auto-compile
+#!#; Guix wrapper
+#\\-~s
+#\\-~s
+"
+ '(begin (let ((current (getenv "GUIX_FOO")))
+ (setenv "GUIX_FOO"
+ (if current
+ (string-append "/some/path:/some/other/path"
+ ":" current)
+ "/some/path:/some/other/path"))))
+ '(let ((cl (command-line)))
+ (apply execl "/anything/cabbage-bash-1.2.3/bin/sh"
+ (car cl)
+ (cons (car cl)
+ (append '("") cl)))))
+ script-contents)
+ (call-with-temporary-directory
+ (lambda (directory)
+ (let ((script-file-name (string-append directory "/foo")))
+ (call-with-output-file script-file-name
+ (lambda (port)
+ (format port script-contents)))
+ (chmod script-file-name #o777)
+
+ (mock ((guix build utils) which (const "GUILE"))
+ (wrap-script script-file-name
+ `("GUIX_FOO" prefix ("/some/path"
+ "/some/other/path"))))
+ (let ((str (call-with-input-file script-file-name get-string-all)))
+ (with-directory-excursion directory
+ (delete-file "foo"))
+ str))))))
+
+(let ((script-contents "\
+#!/anything/cabbage-bash-1.2.3/bin/python3 -and -args
+# vim:fileencoding=utf-8
+print('hello world')"))
+
+ (test-equal "wrap-script, with encoding declaration"
+ (string-append
+ (format #f "\
+#!MYGUILE --no-auto-compile
+#!#; # vim:fileencoding=utf-8
+#\\-~s
+#\\-~s
+"
+ '(begin (let ((current (getenv "GUIX_FOO")))
+ (setenv "GUIX_FOO"
+ (if current
+ (string-append "/some/path:/some/other/path"
+ ":" current)
+ "/some/path:/some/other/path"))))
+ `(let ((cl (command-line)))
+ (apply execl "/anything/cabbage-bash-1.2.3/bin/python3"
+ (car cl)
+ (cons (car cl)
+ (append '("" "-and" "-args") cl)))))
+ script-contents)
+ (call-with-temporary-directory
+ (lambda (directory)
+ (let ((script-file-name (string-append directory "/foo")))
+ (call-with-output-file script-file-name
+ (lambda (port)
+ (format port script-contents)))
+ (chmod script-file-name #o777)
+
+ (wrap-script script-file-name
+ #:guile "MYGUILE"
+ `("GUIX_FOO" prefix ("/some/path"
+ "/some/other/path")))
+ (let ((str (call-with-input-file script-file-name get-string-all)))
+ (with-directory-excursion directory
+ (delete-file "foo"))
+ str))))))
+
+(test-assert "wrap-script, raises condition"
+ (call-with-temporary-directory
+ (lambda (directory)
+ (let ((script-file-name (string-append directory "/foo")))
+ (call-with-output-file script-file-name
+ (lambda (port)
+ (format port "This is not a script")))
+ (chmod script-file-name #o777)
+ (catch 'srfi-34
+ (lambda ()
+ (wrap-script script-file-name
+ #:guile "MYGUILE"
+ `("GUIX_FOO" prefix ("/some/path"
+ "/some/other/path"))))
+ (lambda (type obj)
+ (wrap-error? obj)))))))
+
(test-end)