From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:42979) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1eWTRm-0001hb-12 for guix-patches@gnu.org; Tue, 02 Jan 2018 15:46:07 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1eWTRi-0005yR-1Q for guix-patches@gnu.org; Tue, 02 Jan 2018 15:46:06 -0500 Received: from debbugs.gnu.org ([208.118.235.43]:53067) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1eWTRh-0005y6-UB for guix-patches@gnu.org; Tue, 02 Jan 2018 15:46:01 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1eWTRh-0007A6-O3 for guix-patches@gnu.org; Tue, 02 Jan 2018 15:46:01 -0500 Subject: [bug#29951] [PATCH] WIP guix: Add wrap-script. Resent-Message-ID: Received: from eggs.gnu.org ([2001:4830:134:3::10]:42110) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1eWTQZ-0001FO-FZ for guix-patches@gnu.org; Tue, 02 Jan 2018 15:44:54 -0500 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1eWTQV-0005C7-Cl for guix-patches@gnu.org; Tue, 02 Jan 2018 15:44:51 -0500 Received: from sender-of-o51.zoho.com ([135.84.80.216]:21088) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_256_CBC_SHA1:32) (Exim 4.71) (envelope-from ) id 1eWTQV-0005Bl-4D for guix-patches@gnu.org; Tue, 02 Jan 2018 15:44:47 -0500 From: Ricardo Wurmus Date: Tue, 2 Jan 2018 21:44:34 +0100 MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: quoted-printable Message-ID: <20180102204434.2716-1-rekado@elephly.net> 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 Cc: Ricardo Wurmus , h.goebel@crazy-compilers.com * guix/build/utils.scm (wrap-script): New procedure. --- guix/build/utils.scm | 101 +++++++++++++++++++++++++++++++++++++++++++++++= ++++ 1 file changed, 101 insertions(+) diff --git a/guix/build/utils.scm b/guix/build/utils.scm index 7391307c8..a2efcb31c 100644 --- a/guix/build/utils.scm +++ b/guix/build/utils.scm @@ -3,6 +3,7 @@ ;;; Copyright =C2=A9 2013 Andreas Enge ;;; Copyright =C2=A9 2013 Nikita Karetnikov ;;; Copyright =C2=A9 2015 Mark H Weaver +;;; Copyright =C2=A9 2018 Ricardo Wurmus ;;; ;;; This file is part of GNU Guix. ;;; @@ -84,6 +85,7 @@ fold-port-matches remove-store-references wrap-program + wrap-script invoke =20 locale-category->string)) @@ -1068,6 +1070,105 @@ 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/sh|/gnu/store/[^/]+/bin/(" + (string-join '("python[^ ]*" + "Rscript" + "perl" + "ruby" + "bash" + "sh") "|") + ") ?.*)"))) + (coding-line-regex + (make-regexp + ".*#.*coding[=3D:][[:space:]]*([-[a-zA-Z_0-9].]+)"))) + (lambda* (prog #: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 coding-line) + (call-with-ascii-input-file prog + (lambda (p) + (values (false-if-exception + (and=3D> (regexp-exec interpreter-regex (= read-line p)) + (lambda (m) (match:substring m 1))= )) + (false-if-exception + (and=3D> (regexp-exec coding-line-regex (= read-line p)) + (lambda (m) (match:substring m 0))= ))))))) + (when interpreter + (let* ((header (format #f "\ +#!~a --no-auto-compile +#!#; ~a +#\\-~s +#\\-~s +" + (which "guile") + (or coding-line "Guix wrapper") + (cons 'begin (map update-env vars)) + `(apply execl ,interpreter + (car (command-line)) + (command-line)))) + (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)) + #f)))))))) + =0C ;;; ;;; Locales. --=20 2.15.0