unofficial mirror of guix-patches@gnu.org 
 help / color / mirror / code / Atom feed
* [bug#29951] [PATCH] WIP guix: Add wrap-script.
@ 2018-01-02 20:44 Ricardo Wurmus
  2018-01-03 13:59 ` Hartmut Goebel
                   ` (3 more replies)
  0 siblings, 4 replies; 13+ messages in thread
From: Ricardo Wurmus @ 2018-01-02 20:44 UTC (permalink / raw)
  To: 29951; +Cc: Ricardo Wurmus, h.goebel

* 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

^ permalink raw reply related	[flat|nested] 13+ messages in thread

end of thread, other threads:[~2019-02-08 10:12 UTC | newest]

Thread overview: 13+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2018-01-02 20:44 [bug#29951] [PATCH] WIP guix: Add wrap-script Ricardo Wurmus
2018-01-03 13:59 ` 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

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