ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-25 05:48:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

guix: Add wrap-script.

Browse source 
* 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 2018-01-02 21:43:07 +01:00
parent df2bf40eec
commit 0fb9a8df42
No known key found for this signature in database
GPG key ID: 197A5888235FACAC
2 changed files with 227 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

125
guix/build/utils.scm
View file

@ -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.

102
tests/build-utils.scm
View file

@ -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)