[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[bug#29951] [PATCH]: guix: Add wrap-script.
|
From: |
Ricardo Wurmus |
|
Subject: |
[bug#29951] [PATCH]: guix: Add wrap-script. |
|
Date: |
Thu, 07 Feb 2019 00:10:49 +0100 |
|
User-agent: |
mu4e 1.0; emacs 26.1 |
Here’s a new version which raises a condition on errors, handles
all shebangs (including those with arguments or with custom store
prefix), and which allows the value for “guile” to be overridden.
It comes with tests.
It doesn’t apply automatically when “wrap-program” is used. It might be
a good idea to call it automatically and fall back to “wrap-program” if
the target is not a supported script.
Comments are very welcome!
--
Ricardo
>From 8b0a19b35b6cad2347b68893bf751caec87b9df6 Mon Sep 17 00:00:00 2001
From: Ricardo Wurmus <address@hidden>
Date: Tue, 2 Jan 2018 21:43:07 +0100
Subject: [PATCH] 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 55d34b67e..b7cd748d8 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 7d49446f6..1c9084514 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)
--
2.20.1
- [bug#29951] [PATCH]: guix: Add wrap-script.,
Ricardo Wurmus <=