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.
This commit is contained in:
Ricardo Wurmus
parent
df2bf40eec
commit
0fb9a8df42
2 changed files with 227 additions and 0 deletions
|
|
@ -4,6 +4,7 @@
|
|||
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
|
||||
;;; Copyright © 2015, 2018 Mark H Weaver <mhw@netris.org>
|
||||
;;; Copyright © 2018 Arun Isaac <arunisaac@systemreboot.net>
|
||||
;;; Copyright © 2018, 2019 Ricardo Wurmus <rekado@elephly.net>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
|
|
@ -90,6 +91,11 @@ (define-module (guix build utils)
|
|||
remove-store-references
|
||||
wrapper?
|
||||
wrap-program
|
||||
wrap-script
|
||||
|
||||
wrap-error?
|
||||
wrap-error-program
|
||||
wrap-error-type
|
||||
|
||||
invoke
|
||||
invoke-error?
|
||||
|
|
@ -1042,6 +1048,11 @@ (define pattern
|
|||
(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 @@ (define (export-variable lst)
|
|||
(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.
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2012, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
|
||||
;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
|
|
@ -122,4 +123,105 @@ (define-module (test-build-utils)
|
|||
(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)
|
||||
|
|
|
|||
Loading…
Reference in a new issue