From 8ff3392a7c5b098fe64aab2a076ea6fe02c7575e Mon Sep 17 00:00:00 2001
From: Jim Ursetto <address@hidden>
Date: Thu, 14 Apr 2016 12:31:33 -0500
Subject: [PATCH 3/3] Add (run*) to setup-api; change (compile) from shell to
 direct call (#1277)

A new macro (run*) is exported, which is like (run) but does not rely on
the shell.  (compile) is changed to be (run* (csc ...)).

This permits blacklisted environment variables such as DYLD_LIBRARY_PATH
to be passed to csc on OS X 10.11, addressing a problem with the
deployment tests in `make check` in bug #1277.

Due to the changed semantics of (compile), certain eggs which rely on
backticks or pass flags as single strings to (compile) will need to be
updated; for example, to use (run (csc ...)).
---
 setup-api.scm | 106 +++++++++++++++++++++++++++++++++++++++++++---------------
 1 file changed, 79 insertions(+), 27 deletions(-)

diff --git a/setup-api.scm b/setup-api.scm
index f4168a6..b34d27f 100644
--- a/setup-api.scm
+++ b/setup-api.scm
@@ -37,6 +37,7 @@
 (module setup-api
 
     ((run execute)
+     (run* execute*)
      compile
      standard-extension
      host-extension
@@ -212,12 +213,21 @@
   (set! *registered-programs* 
     (alist-cons (->string name) path *registered-programs*)))
 
+;; Not used here, but exported; may be relied on externally
 (define (find-program name)
+  (find-program* name #t))
+
+;; (run) does not quote or normalize unregistered program names, so names containing spaces are
+;; interpolated unchanged into the shell command line; this behavior is explicitly relied upon
+;; in *copy-command* for example.  This complicates the logic.
+(define (find-program* name shell?)
   (let* ((name (->string name))
 	 (a (assoc name *registered-programs*)))
-    (if a
-	(shellpath (cdr a))
-	name)))
+    (if shell?
+	(if a
+	    (shellpath (cdr a))
+	    name) ; deliberately not quoted
+	(normalize-pathname (if a (cdr a) name)))))
 
 (let ()
   (define (reg name rname) 
@@ -234,31 +244,40 @@
   (and-let* ((tp (runtime-prefix)))
     (make-pathname tp fname)))
 
-(define (fixpath prg)
+(define (_fixpath prg shell?)
+  ;; Requires shell? argument because unregistered programs should not be quoted,
+  ;; so we cannot simply quote in the caller.
   (cond ((string=? prg "csc")
-	 (string-intersperse 
-	  (cons*
-	   (find-program "csc")
-	   "-feature" "compiling-extension" 
-	   (if (or (deployment-mode)
-		   (and (feature? #:cross-chicken)
-			(not (host-extension))))
-	       "" "-setup-mode")
-	   (if (keep-intermediates) "-k" "")
-	   (if (host-extension) "-host" "")
-	   (if (deployment-mode) "-deployed" "")
-	   (append
-	    (map (lambda (f)
-		   (string-append "-feature " (symbol->string f)))
-		 (extra-features))
-	    (map (lambda (f)
-		   (string-append "-no-feature " (symbol->string f)))
-		 (extra-nonfeatures))
-	    *csc-options*) )
-	  " ") )
+	 `(,(find-program* "csc" shell?)
+	   "-feature" "compiling-extension"
+	   ,@(if (or (deployment-mode)
+		     (and (feature? #:cross-chicken)
+			  (not (host-extension))))
+		 '() '("-setup-mode"))
+	   ,@(if (keep-intermediates) '("-k") '())
+	   ,@(if (host-extension) '("-host") '())
+	   ,@(if (deployment-mode) '("-deployed") '())
+	   ;; done up to here
+	   ,@(map (lambda (f)
+		    `("-feature" ,f))
+		  (extra-features))
+	   ,@(map (lambda (f)
+		    `("-no-feature" ,f))
+		  (extra-nonfeatures))
+	   ,@*csc-options* ) )
 	((and (string-prefix? "./" prg) *windows-shell*)
-	 (shellpath (substring prg 2)))
-	(else (find-program prg))))
+	 (let ((prg (substring prg 2)))
+	   (if shell?
+	       (shellpath prg)
+	       (normalize-pathname prg))))
+	(else (list (find-program* prg shell?)))))
+
+(define (fixpath prg) ; compress result list into a shell command string
+  (let ((path (_fixpath prg #t)))
+    (string-intersperse (map ->string path)
+			" ")))
+(define (fixpath* prg)
+  (_fixpath (->string prg) #f))
 
 (define (execute explist)
   (define (smooth lst)
@@ -275,10 +294,25 @@
     ((_ exp ...)
      (execute (list `exp ...)))))
 
+(define (execute* explist)
+  (for-each
+   (lambda (cmdlist)
+     (let ((L (append (fixpath* (car cmdlist))
+		      (cdr cmdlist))))
+       (when (run-verbose)  ; should be part of $exec ?
+	 (printf "  ~A~%~!" (string-intersperse (map ->string L))))
+       ($exec (car L) (cdr L))))
+   explist))
+
+(define-syntax run*
+  (syntax-rules ()
+    ((_ exp ...)
+     (execute* (list `exp ...)))))
+
 (define-syntax compile
   (syntax-rules ()
     ((_ exp ...)
-     (run (csc exp ...)))))
+     (run* (csc exp ...)))))
 
 
 ;;; Processing setup scripts
@@ -644,6 +678,24 @@
       (error
        (sprintf "shell command failed with nonzero exit status ~a:~%~%  ~a" r str)))))
 
+(define ($exec cmd args)
+  (let ((verbose #f) (dry-run #f))
+    (let* ((args (map ->string args))
+	   (str (string-intersperse (cons cmd args)))) ; no quoting is rendered
+      (when verbose (print str))
+      (receive (_ normal return-code)
+	  (if dry-run
+	      (values #f #t 0)
+	      (process-wait (process-run cmd args)))
+	(cond ((= 0 return-code)
+	       (unless normal
+		 (error "unexpected 0 return code with abnormal exit" str)))
+	      (normal
+	       (error "command terminated with non-zero exit status" return-code str))
+	      (else
+	       (error "command terminated on signal" return-code str)))))))
+
+
 (define (setup-error-handling)
   (current-exception-handler
    (lambda (c)
-- 
2.2.1