From: Ricardo Wurmus Date: Tue, 2 Jan 2018 20:43:07 +0000 (+0100) Subject: guix: Add wrap-script. X-Git-Url: https://git.hcoop.net/jackhill/guix/guix.git/commitdiff_plain/0fb9a8df429a7b9f40610ff15baaff0d8e31e8cf 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. --- diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 55d34b67e7..b7cd748d81 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2015, 2018 Mark H Weaver ;;; Copyright © 2018 Arun Isaac +;;; Copyright © 2018, 2019 Ricardo Wurmus ;;; ;;; 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 7d49446f66..1c9084514d 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 +;;; Copyright © 2019 Ricardo Wurmus ;;; ;;; 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)