From: Ricardo Wurmus <rekado@elephly.net>
To: 29951@debbugs.gnu.org
Cc: Ricardo Wurmus <rekado@elephly.net>, h.goebel@crazy-compilers.com
Subject: [bug#29951] [PATCH] WIP guix: Add wrap-script.
Date: Tue, 2 Jan 2018 21:44:34 +0100 [thread overview]
Message-ID: <20180102204434.2716-1-rekado@elephly.net> (raw)
* 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 © 2013 Andreas Enge <andreas@enge.fr>
;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
+;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -84,6 +85,7 @@
fold-port-matches
remove-store-references
wrap-program
+ wrap-script
invoke
locale-category->string))
@@ -1068,6 +1070,105 @@ with definitions for VARS."
(chmod prog-tmp #o755)
(rename-file prog-tmp prog))))
+(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[=:][[:space:]]*([-[a-zA-Z_0-9].]+)")))
+ (lambda* (prog #: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 coding-line)
+ (call-with-ascii-input-file prog
+ (lambda (p)
+ (values (false-if-exception
+ (and=> (regexp-exec interpreter-regex (read-line p))
+ (lambda (m) (match:substring m 1))))
+ (false-if-exception
+ (and=> (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))))))))
+
\f
;;;
;;; Locales.
--
2.15.0
next reply other threads:[~2018-01-02 20:46 UTC|newest]
Thread overview: 13+ messages / expand[flat|nested] mbox.gz Atom feed top
2018-01-02 20:44 Ricardo Wurmus [this message]
2018-01-03 13:59 ` [bug#29951] [PATCH] WIP guix: Add wrap-script Hartmut Goebel
2018-01-05 8:19 ` Ricardo Wurmus
2018-01-05 10:06 ` Hartmut Goebel
2018-08-02 6:26 ` Chris Marusich
2018-08-02 7:23 ` Ricardo Wurmus
2018-08-02 8:37 ` Chris Marusich
2018-01-12 22:52 ` Ludovic Courtès
2018-08-02 8:18 ` Jelle Licht
2018-08-02 8:37 ` Ricardo Wurmus
2018-08-02 9:22 ` Nils Gillmann
2019-02-06 23:10 ` [bug#29951] [PATCH]: " Ricardo Wurmus
2019-02-08 10:10 ` bug#29951: " Ricardo Wurmus
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20180102204434.2716-1-rekado@elephly.net \
--to=rekado@elephly.net \
--cc=29951@debbugs.gnu.org \
--cc=h.goebel@crazy-compilers.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).