From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([209.51.188.92]:47534) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1grWMN-0002Pq-SQ for guix-patches@gnu.org; Wed, 06 Feb 2019 18:12:05 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1grWMM-0006YI-Fi for guix-patches@gnu.org; Wed, 06 Feb 2019 18:12:03 -0500 Received: from debbugs.gnu.org ([209.51.188.43]:37069) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1grWMM-0006Y2-9I for guix-patches@gnu.org; Wed, 06 Feb 2019 18:12:02 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1grWMM-00033S-0o for guix-patches@gnu.org; Wed, 06 Feb 2019 18:12:02 -0500 Subject: [bug#29951] [PATCH]: guix: Add wrap-script. References: <20180102204434.2716-1-rekado@elephly.net> In-Reply-To: <20180102204434.2716-1-rekado@elephly.net> Resent-Message-ID: From: Ricardo Wurmus Date: Thu, 07 Feb 2019 00:10:49 +0100 Message-ID: <87d0o4fr7q.fsf@elephly.net> MIME-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 29951@debbugs.gnu.org --=-=-= Content-Type: text/plain; charset=utf-8 Content-Transfer-Encoding: quoted-printable Here=E2=80=99s 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 =E2=80=9Cguile=E2=80=9D to be overr= idden. It comes with tests. It doesn=E2=80=99t apply automatically when =E2=80=9Cwrap-program=E2=80=9D = is used. It might be a good idea to call it automatically and fall back to =E2=80=9Cwrap-program= =E2=80=9D if the target is not a supported script. Comments are very welcome! --=20 Ricardo --=-=-= Content-Type: text/x-patch; charset=utf-8 Content-Disposition: inline; filename=0001-guix-Add-wrap-script.patch Content-Transfer-Encoding: quoted-printable >From 8b0a19b35b6cad2347b68893bf751caec87b9df6 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus 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 =C2=A9 2013 Nikita Karetnikov ;;; Copyright =C2=A9 2015, 2018 Mark H Weaver ;;; Copyright =C2=A9 2018 Arun Isaac +;;; Copyright =C2=A9 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 =20 invoke invoke-error? @@ -1042,6 +1048,11 @@ known as `nuke-refs' in Nixpkgs." (put-u8 out (char->integer char)) result)))))) =20 +(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)))) =20 +(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[=3D:][[: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 V= ARS +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 interpret= ed +as a comment in the script's language. + +Special encoding comments as supported by Python are recreated on the seco= nd +line. + +Note that this procedure can only be used once per file as Guile scripts a= re +not supported." + (define update-env + (match-lambda + ((var sep '=3D 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 '=3D 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=3D> (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 =C2=A9 2012, 2015, 2016 Ludovic Court=C3=A8s +;;; Copyright =C2=A9 2019 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -122,4 +123,105 @@ (and (zero? (close-pipe pipe)) str)))))) =20 +(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=3Dutf-8 +print('hello world')")) + + (test-equal "wrap-script, with encoding declaration" + (string-append + (format #f "\ +#!MYGUILE --no-auto-compile +#!#; # vim:fileencoding=3Dutf-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) --=20 2.20.1 --=-=-=--