Here is a patch that will make CFFI play better with ASDF bundles.
This allows delivery with a single .so and/or .a file for all the
wrappers in a system, which can be automatically linked into ECL (and
in the future, in SBCL or other implementations, for application
delivery).
Also, report for a bug, not fixed in the attached patch: compiling,
linking, etc., should be atomic, by using temporary pathnames;
otherwise, there is a race condition when multiple processes try to
execute a script that depends on a CFFI library. Recent-enough ASDF
3.1.2 provides with-temporary-file to help, and 3.1.5 uses it
internally for its own targets, but some implementations still lag
behind with ASDF 3.0.x, and ASDF can't backwards-compatibly use
with-temporary-file for you, so you must use it yourself.
This patch also drops support for ASDF 2 or earlier, because backwards
compatibility is hard, and not necessary: today, all implementations
provide ASDF 3.
—♯ƒ • François-René ÐVB Rideau •Reflection&Cybernethics• http://fare.tunes.org
The least deviation from truth will be multiplied later.
— Aristotle
From 8f3dc5b46a487e4a3d884525d4f12458e395c9d6 Mon Sep 17 00:00:00 2001
From: Francois-Rene Rideau <tu...@google.com>
Date: Wed, 16 Sep 2015 23:17:05 -0400
Subject: [PATCH] Make CFFI-grovel play well with ASDF 3.1.5.12.
Create linkable object files and include them in output-files for
compile-op, so that they can be found and linked by a recent-enough
ASDF (3.1.5.12 or later), allowing for delivery of a system with a
single static and/or dynamic library, and in the future, delivery
of a standalone executable that statically links required extensions.
---
cffi-grovel.asd | 7 +--
grovel/asdf.lisp | 159 ++++++++++++++++++++++++++---------------------------
grovel/grovel.lisp | 114 +++++++++++++++++++++++++-------------
grovel/invoke.lisp | 149 -------------------------------------------------
4 files changed, 158 insertions(+), 271 deletions(-)
delete mode 100644 grovel/invoke.lisp
diff --git a/cffi-grovel.asd b/cffi-grovel.asd
index 11ac4a1..f1ddf8a 100644
--- a/cffi-grovel.asd
+++ b/cffi-grovel.asd
@@ -25,17 +25,16 @@
;;; DEALINGS IN THE SOFTWARE.
;;;
-(asdf:defsystem cffi-grovel
+(defsystem "cffi-grovel"
:description "The CFFI Groveller"
:author "Dan Knapp <dan...@accela.net>"
- :depends-on (cffi alexandria)
+ :depends-on ("cffi" "alexandria" (:version "asdf" "3"))
:licence "MIT"
:components
- ((:module grovel
+ ((:module "grovel"
:serial t
:components
((:file "package")
- (:file "invoke")
(:static-file "common.h")
(:file "grovel")
(:file "asdf")))))
diff --git a/grovel/asdf.lisp b/grovel/asdf.lisp
index 506cfba..3490eab 100644
--- a/grovel/asdf.lisp
+++ b/grovel/asdf.lisp
@@ -30,139 +30,136 @@
(in-package #:cffi-grovel)
-(defun ensure-pathname (thing)
- (if (typep thing 'logical-pathname)
- (translate-logical-pathname thing)
- (pathname thing)))
-
(defclass cc-flags-mixin ()
((cc-flags :initform nil :accessor cc-flags-of :initarg :cc-flags)))
(defmethod asdf:perform :around ((op asdf:compile-op) (file cc-flags-mixin))
- (declare (ignorable op))
(let ((*cc-flags* (append (ensure-list (cc-flags-of file))
*cc-flags*)))
(call-next-method)))
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass process-op (#-asdf3 asdf:operation
- #+asdf3 asdf:downward-operation)
- ()
- (:documentation "This ASDF operation performs the steps necessary
+(defclass process-op (asdf:downward-operation)
+ ()
+ (:documentation "This ASDF operation performs the steps necessary
to generate a compilable and loadable lisp file from a
PROCESS-OP-INPUT component."))
- (defclass process-op-input (asdf:cl-source-file)
- ((generated-lisp-file-type
- :initarg :generated-lisp-file-type
- :accessor generated-lisp-file-type
- :documentation "The :TYPE argument to use for the generated lisp file."))
- (:default-initargs
- :generated-lisp-file-type "generated-lisp-file")
- (:documentation "This ASDF component represents a file that is
+(defclass process-op-input (asdf:cl-source-file)
+ ((generated-lisp-file-type
+ :initarg :generated-lisp-file-type
+ :accessor generated-lisp-file-type
+ :documentation "The :TYPE argument to use for the generated lisp file."))
+ (:default-initargs
+ :generated-lisp-file-type "generated-lisp-file")
+ (:documentation "This ASDF component represents a file that is
used as input to a function that generates lisp source file. This
component acts as if it is a CL-SOURCE-FILE by applying the
COMPILE-OP and LOAD-SOURCE-OP operations to the file generated by
- PROCESS-OP.")))
+ PROCESS-OP."))
(defmethod asdf:input-files ((op process-op) (c process-op-input))
(list (asdf:component-pathname c)))
+(defmethod asdf:input-files ((op asdf:compile-op) (c process-op-input))
+ (list (first (asdf:output-files 'process-op c))))
+
(defmethod asdf:component-depends-on ((op process-op) (c process-op-input))
- `(#-asdf3 (asdf:load-op ,@(asdf::component-load-dependencies c))
- #+asdf3 (asdf:prepare-op ,c)
- ,@(call-next-method)))
+ `((asdf:prepare-op ,c) ,@(call-next-method)))
(defmethod asdf:component-depends-on ((op asdf:compile-op) (c process-op-input))
- (declare (ignorable op))
- `((process-op ,(asdf:component-name c))
- ,@(call-next-method)))
+ `((process-op ,c) ,@(call-next-method)))
(defmethod asdf:component-depends-on ((op asdf:load-source-op) (c process-op-input))
- (declare (ignorable op))
- `((process-op ,(asdf:component-name c))
- ,@(call-next-method)))
-
-(defmethod asdf:perform ((op asdf:compile-op) (c process-op-input))
- (let ((generated-lisp-file (first (asdf:output-files (make-instance 'process-op) c))))
- (asdf:perform op (make-instance 'asdf:cl-source-file
- :name (asdf:component-name c)
- :parent (asdf:component-parent c)
- :pathname generated-lisp-file))))
-
-(defmethod asdf:perform ((op asdf:load-source-op) (c process-op-input))
- (let ((generated-lisp-file (first (asdf:output-files (make-instance 'process-op) c))))
- (asdf:perform op (make-instance 'asdf:cl-source-file
- :name (asdf:component-name c)
- :parent (asdf:component-parent c)
- :pathname generated-lisp-file))))
+ `((process-op ,c) ,@(call-next-method)))
;;;# ASDF component: GROVEL-FILE
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass grovel-file (process-op-input cc-flags-mixin)
- ()
- (:default-initargs
- :generated-lisp-file-type "processed-grovel-file")
- (:documentation
- "This ASDF component represents an input file that is processed
- by PROCESS-GROVEL-FILE.")))
+(defclass grovel-file (process-op-input cc-flags-mixin)
+ ()
+ (:default-initargs
+ :generated-lisp-file-type "processed-grovel-file")
+ (:documentation
+ "This ASDF component represents an input file that is processed
+ by PROCESS-GROVEL-FILE."))
(defmethod asdf:output-files ((op process-op) (c grovel-file))
- (let* ((input-file (asdf:component-pathname c))
+ (let* ((input-file (first (asdf:input-files op c)))
(output-file (make-pathname :type (generated-lisp-file-type c)
:defaults input-file))
- (c-file (make-c-file-name output-file)))
+ (c-file (make-c-file-name output-file "__grovel")))
(list output-file
c-file
(exe-filename c-file))))
(defmethod asdf:perform ((op process-op) (c grovel-file))
- (let ((output-file (first (asdf:output-files op c)))
- (input-file (asdf:component-pathname c)))
- (ensure-directories-exist (directory-namestring output-file))
- (let ((tmp-file (process-grovel-file input-file output-file)))
- (unwind-protect
- (alexandria:copy-file tmp-file output-file :if-to-exists :supersede)
- (delete-file tmp-file)))))
+ (let* ((output-file (first (asdf:output-files op c)))
+ (input-file (first (asdf:input-files op c)))
+ (tmp-file (process-grovel-file input-file output-file)))
+ (uiop:rename-file-overwriting-target tmp-file output-file)))
+
;;;# ASDF component: WRAPPER-FILE
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass wrapper-file (process-op-input cc-flags-mixin)
- ((soname :initform nil :initarg :soname :accessor soname-of))
- (:default-initargs
- :generated-lisp-file-type "processed-wrapper-file")
- (:documentation
- "This ASDF component represents an input file that is processed
- by PROCESS-WRAPPER-FILE. This generates a foreign library and
- matching CFFI bindings that are subsequently compiled and
- loaded.")))
+(defclass wrapper-file (process-op-input cc-flags-mixin)
+ ((soname :initform nil :initarg :soname :accessor soname-of))
+ (:default-initargs
+ :generated-lisp-file-type "processed-wrapper-file")
+ (:documentation
+ "This ASDF component represents an input file that is processed
+ by PROCESS-WRAPPER-FILE. This generates a foreign library and
+ matching CFFI bindings that are subsequently compiled and
+ loaded."))
(defun wrapper-soname (c)
(or (soname-of c)
(asdf:component-name c)))
(defmethod asdf:output-files ((op process-op) (c wrapper-file))
- (let* ((input-file (asdf:component-pathname c))
+ (let* ((input-file (first (asdf:input-files op c)))
(output-file (make-pathname :type (generated-lisp-file-type c)
:defaults input-file))
- (c-file (make-c-file-name output-file))
+ (c-file (make-c-file-name output-file "__wrapper"))
+ (o-file (make-o-file-name output-file "__wrapper"))
(lib-soname (wrapper-soname c)))
(list output-file
+ (lib-filename (make-soname lib-soname output-file))
c-file
- (lib-filename (make-soname lib-soname output-file)))))
+ o-file)))
+
+;;; Declare the .o and .so files as compilation outputs,
+;;; so they get picked up by bundle operations.
+#.(when (uiop:version<= "3.1.5.12" (asdf:asdf-version))
+ '(defmethod asdf:output-files ((op asdf:compile-op) (c wrapper-file))
+ (destructuring-bind (generated-lisp lib-file c-file o-file) (asdf:output-files 'process-op c)
+ (declare (ignore generated-lisp c-file))
+ (multiple-value-bind (files translatedp) (call-next-method)
+ (values (append files (list lib-file o-file)) translatedp)))))
(defmethod asdf:perform ((op process-op) (c wrapper-file))
- (let ((output-file (first (asdf:output-files op c)))
- (input-file (asdf:component-pathname c)))
- (ensure-directories-exist (directory-namestring output-file))
- (let ((tmp-file (process-wrapper-file input-file output-file (wrapper-soname c))))
+ (let* ((output-file (first (asdf:output-files op c)))
+ (input-file (first (asdf:input-files op c)))
+ (tmp-file (process-wrapper-file
+ input-file
+ :output-defaults output-file
+ :lib-soname (wrapper-soname c))))
(unwind-protect
(alexandria:copy-file tmp-file output-file :if-to-exists :supersede)
- (delete-file tmp-file)))))
+ (delete-file tmp-file))))
+
;; Allow for naked :grovel-file and :wrapper-file in asdf definitions.
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (setf (find-class 'asdf::cffi-grovel-file) (find-class 'grovel-file))
- (setf (find-class 'asdf::cffi-wrapper-file) (find-class 'wrapper-file)))
+(setf (find-class 'asdf::cffi-grovel-file) (find-class 'grovel-file))
+(setf (find-class 'asdf::cffi-wrapper-file) (find-class 'wrapper-file))
+
+;; Implement link-op on image-based platforms.
+
+#-(or clasp ecl mkcl)
+(defmethod asdf:perform ((o asdf/bundle::link-op) (c asdf:system))
+ (let* ((inputs (asdf:input-files o c))
+ (output (first (asdf:output-files o c)))
+ (kind (asdf/bundle::bundle-type o)))
+ (when output ;; some operations skip any output when there is no input
+ (ecase kind
+ (:program (cc-create-exe output inputs))
+ ((:lib :static-library) (cc-link-static-library output inputs))
+ ((:dll :shared-library) (cc-link-shared-library output inputs))))))
diff --git a/grovel/grovel.lisp b/grovel/grovel.lisp
index b821841..fa23a6f 100644
--- a/grovel/grovel.lisp
+++ b/grovel/grovel.lisp
@@ -37,6 +37,13 @@
for trim = (string-trim '(#\Space #\Tab #\Newline) s)
unless (string= "" trim) collect trim))
+(defun invoke (command &rest args)
+ (when (pathnamep command)
+ (setf command (cffi-sys:native-namestring command)))
+ (format *debug-io* "; ~A~{ ~A~}~%" command args)
+ (uiop:run-program `(,command ,@args) :output :interactive :error-output :interactive))
+
+
;;;# Error Conditions
(define-condition grovel-error (simple-error) ())
@@ -194,11 +201,21 @@ int main(int argc, char**argv) {
(defun header-form-p (form)
(member (form-kind form) *header-forms*))
-(defun make-c-file-name (output-defaults)
- (make-pathname :type "c" :defaults output-defaults))
+(defun make-c-file-name (output-defaults &optional suffix)
+ (make-pathname :type "c"
+ :name (format nil "~A~@[~A~]" (pathname-name output-defaults) suffix)
+ :defaults output-defaults))
+
+(defun o-type ()
+ (uiop:os-cond ((uiop:os-unix-p) "o") ((uiop:os-windows-p) "obj") (t "o")))
+
+(defun make-o-file-name (output-defaults &optional suffix)
+ (make-pathname :type (o-type)
+ :name (format nil "~A~@[~A~]" (pathname-name output-defaults) suffix)
+ :defaults output-defaults))
(defun generate-c-file (input-file output-defaults)
- (let ((c-file (make-c-file-name output-defaults)))
+ (let ((c-file (make-c-file-name output-defaults "__grovel")))
(with-open-file (out c-file :direction :output :if-exists :supersede)
(with-open-file (in input-file :direction :input)
(flet ((read-forms (s)
@@ -263,7 +280,7 @@ int main(int argc, char**argv) {
#+darwin (list "-I" "/opt/local/include/")
#-darwin nil
;; ECL internal flags
- #+ecl (list c::*cc-flags*)
+ #+ecl (remove-if 'uiop:emptyp (uiop:split-string c::*cc-flags* :separator " "))
;; FreeBSD non-base header files
#+freebsd (list "-I" "/usr/local/include/")))
@@ -277,10 +294,9 @@ int main(int argc, char**argv) {
(4 (list "-m32"))
(8 (list "-m64"))))
-(defparameter *platform-library-flags*
+(defparameter *shared-library-flags*
(list #+darwin "-bundle"
- #-darwin "-shared"
- #-windows "-fPIC"))
+ #-darwin "-shared"))
(defun host-and-directory-namestring (pathname)
(namestring
@@ -288,24 +304,44 @@ int main(int argc, char**argv) {
:type nil
:defaults pathname)))
-(defun cc-compile-and-link (input-file output-file &key library)
- (let ((arglist
- `(,(or (getenv "CC") *cc*)
- ,@*cpu-word-size-flags*
- ,@*cc-flags*
- ;; add the cffi directory to the include path to make common.h visible
- ,(format nil "-I~A"
- (host-and-directory-namestring
- (truename (asdf:system-definition-pathname :cffi-grovel))))
- ,@(when library *platform-library-flags*)
- "-o" ,(native-namestring output-file)
- ,(native-namestring input-file))))
- (when library
- ;; if it's a library that may be used, remove it
- ;; so we won't possibly be overwriting the code of any existing process
- (ignore-some-conditions (file-error)
- (delete-file output-file)))
- (apply #'invoke arglist)))
+(defun program-argument (x)
+ (etypecase x
+ (string x)
+ (pathname (native-namestring x))))
+
+(defun invoke-cc (&rest args)
+ (apply 'invoke `(,(or (getenv "CC") *cc*)
+ ,@*cpu-word-size-flags*
+ ,@*cc-flags*
+ ,(format nil "-I~A"
+ (truename (asdf:system-source-directory :cffi-grovel)))
+ ,@args)))
+
+(defun cc-compile (output-file input-file)
+ (invoke-cc
+ #-windows "-fPIC"
+ "-o" (native-namestring output-file)
+ "-c" (native-namestring input-file)))
+
+(defun cc-create-exe (output-file inputs)
+ (apply 'invoke-cc
+ "-o" (native-namestring output-file)
+ (mapcar 'program-argument inputs)))
+
+(defun cc-link-static-library (output-file inputs)
+ (apply 'invoke
+ `(#+unix ,@`("ar" "rcs" ,(native-namestring output-file))
+ #+windows ,@'("lib" "-nologo" ,(format nil "-out:~A" (native-namestring output-file)))
+ ,@(mapcar 'program-argument inputs))))
+
+(defun cc-link-shared-library (output-file inputs)
+ ;; remove the library so we won't possibly be overwriting
+ ;; the code of any existing process
+ (uiop:delete-file-if-exists output-file)
+ (apply 'invoke-cc
+ "-o" (native-namestring output-file)
+ `(,@*shared-library-flags*
+ ,@(mapcar 'program-argument inputs))))
;;; *PACKAGE* is rebound so that the IN-PACKAGE form can set it during
;;; *the extent of a given grovel file.
@@ -314,7 +350,7 @@ int main(int argc, char**argv) {
(let* ((c-file (generate-c-file input-file output-defaults))
(exe-file (exe-filename c-file))
(lisp-file (tmp-lisp-filename c-file)))
- (cc-compile-and-link c-file exe-file)
+ (cc-create-exe exe-file (list c-file))
(invoke exe-file (native-namestring lisp-file))
lisp-file)))
@@ -402,9 +438,9 @@ int main(int argc, char**argv) {
(ecase type
(integer
(format out "~& if(_64_BIT_VALUE_FITS_SIGNED_P(~A))~%" c-name)
- (format out " fprintf(output, \"%lli\", (int64_t) ~A);" c-name)
+ (format out " fprintf(output, \"%lli\", (long long signed) ~A);" c-name)
(format out "~& else~%")
- (format out " fprintf(output, \"%llu\", (uint64_t) ~A);" c-name))
+ (format out " fprintf(output, \"%llu\", (long long unsigned) ~A);" c-name))
(double-float
(format out "~& fprintf(output, \"%s\", print_double_for_lisp((double)~A));~%" c-name)))
(when documentation
@@ -519,8 +555,8 @@ int main(int argc, char**argv) {
(c-export out slot-lisp-name)))
(c-format out "(cffi:defcstruct (")
(c-print-symbol out struct-lisp-name t)
- (c-printf out " :size %i)"
- (format nil "sizeof(~A)" struct-c-name))
+ (c-printf out " :size %llu)"
+ (format nil "(long long unsigned) sizeof(~A)" struct-c-name))
(when documentation
(c-format out "~% ~S" documentation))
(dolist (slot slots)
@@ -818,7 +854,7 @@ string."
(defun generate-c-lib-file (input-file output-defaults)
(let ((*lisp-forms* nil)
- (c-file (make-c-file-name output-defaults)))
+ (c-file (make-c-file-name output-defaults "__wrapper")))
(with-open-file (out c-file :direction :output :if-exists :supersede)
(with-open-file (in input-file :direction :input)
(write-string *header* out)
@@ -860,13 +896,17 @@ string."
;;; *PACKAGE* is rebound so that the IN-PACKAGE form can set it during
;;; *the extent of a given wrapper file.
-(defun process-wrapper-file (input-file output-defaults lib-soname)
+(defun process-wrapper-file (input-file
+ &key
+ (output-defaults (make-pathname :defaults input-file :type "processed"))
+ lib-soname)
(with-standard-io-syntax
- (let ((lib-file
- (lib-filename (make-soname lib-soname output-defaults))))
- (multiple-value-bind (c-file lisp-forms)
- (generate-c-lib-file input-file output-defaults)
- (cc-compile-and-link c-file lib-file :library t)
+ (multiple-value-bind (c-file lisp-forms)
+ (generate-c-lib-file input-file output-defaults)
+ (let ((lib-file (lib-filename (make-soname lib-soname output-defaults)))
+ (o-file (make-o-file-name output-defaults "__wrapper")))
+ (cc-compile o-file c-file)
+ (cc-link-shared-library lib-file (list o-file))
;; FIXME: hardcoded library path.
(values (generate-bindings-file lib-file lib-soname lisp-forms output-defaults)
lib-file)))))
diff --git a/grovel/invoke.lisp b/grovel/invoke.lisp
deleted file mode 100644
index 11fac80..0000000
--- a/grovel/invoke.lisp
+++ /dev/null
@@ -1,149 +0,0 @@
-;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
-;;;
-;;; invoke.lisp --- Half-baked portable run-program.
-;;;
-;;; Copyright (C) 2005-2006, Dan Knap <dan...@accela.net>
-;;; Copyright (C) 2005-2006, Emily Backes <lu...@accela.net>
-;;; Copyright (C) 2007, Stelian Ionescu <sione...@cddr.org>
-;;; Copyright (C) 2007, Luis Oliveira <lolive...@common-lisp.net>
-;;;
-;;; Permission is hereby granted, free of charge, to any person
-;;; obtaining a copy of this software and associated documentation
-;;; files (the "Software"), to deal in the Software without
-;;; restriction, including without limitation the rights to use, copy,
-;;; modify, merge, publish, distribute, sublicense, and/or sell copies
-;;; of the Software, and to permit persons to whom the Software is
-;;; furnished to do so, subject to the following conditions:
-;;;
-;;; The above copyright notice and this permission notice shall be
-;;; included in all copies or substantial portions of the Software.
-;;;
-;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
-;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
-;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
-;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
-;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
-;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
-;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
-;;; DEALINGS IN THE SOFTWARE.
-;;;
-
-(in-package #:cffi-grovel)
-
-;;;# Shell Execution
-
-#-(or abcl allegro clisp cmu ecl lispworks openmcl sbcl scl)
-(grovel-error "%INVOKE is unimplemented for this Lisp. Patches welcome.")
-
-;; FIXME: doesn't do shell quoting
-#+abcl
-(defun %invoke (command arglist)
- (let ((cmdline (reduce (lambda (str1 str2)
- (concatenate 'string str1 " " str2))
- arglist :initial-value command))
- (stream (make-string-output-stream)))
- (values (ext:run-shell-command cmdline :output stream)
- (get-output-stream-string stream))))
-
-(defun process-output (process-stream)
- (with-open-stream (process-stream process-stream)
- (with-output-to-string (str)
- (loop for char = (read-char process-stream nil)
- while char
- do (write-char char str)))))
-
-#+clisp
-(defun %invoke (command arglist)
- (let* ((output-file
- (make-pathname
- :name (format nil "clisp-cffi-invoke-~A-~A.tmp"
- (get-universal-time)
- (random 1000))))
- (ret (ext:run-program command
- :arguments arglist
- :output output-file)))
- (with-open-file (stream output-file :direction :input)
- (multiple-value-prog1
- (values (etypecase ret
- ((eql nil) 0)
- ((eql t) 1)
- (integer ret))
- (process-output stream))
- (delete-file output-file)))))
-
-#+ecl
-(defun %invoke (command arglist)
- (multiple-value-bind (output-stream exit-code)
- (ext:run-program "/bin/sh"
- (list "-c"
- (format nil "~A~{ ~A~}" command arglist))
- :wait t :output :stream :input nil :error nil)
- (values exit-code
- (process-output output-stream))))
-
-#+(or cmu scl)
-(defun %invoke (command arglist)
- (let* ((process (ext:run-program command arglist
- :output :stream
- :wait nil
- :error :output))
- (output (process-output (ext:process-output process))))
- (ext:process-wait process)
- (values (ext:process-exit-code process) output)))
-
-#+sbcl
-(defun %invoke (command arglist)
- (let* ((process (sb-ext:run-program command arglist
- :output :stream
- :wait nil
- :error :output
- :search t))
- (output (process-output (sb-ext:process-output process))))
- (sb-ext:process-wait process)
- (values (sb-ext:process-exit-code process) output)))
-
-#+openmcl
-(defun %invoke (command arglist)
- (let* ((exit-code)
- (output (with-output-to-string (s)
- (let ((process (ccl:run-program command arglist
- :output s
- :error :output)))
- (setq exit-code (nth-value 1 (ccl:external-process-status process)))))))
- (values exit-code output)))
-
-#+allegro
-(eval-when (:compile-toplevel :load-toplevel :execute)
- (require '#:osi))
-
-#+allegro
-(defun %invoke (command arglist)
- (let ((cmd #-mswindows (concatenate 'vector (list command command) arglist)
- #+mswindows (format nil "~A~{ ~A~}" command arglist)))
- (multiple-value-bind (output error-output exit-code)
- (excl.osi:command-output cmd :whole t)
- (declare (ignore error-output))
- (values exit-code output))))
-
-;;; FIXME: Runs shell, and arguments are unquoted.
-#+lispworks
-(defun %invoke (command arglist)
- (let ((s (make-string-output-stream)))
- (values (sys:call-system-showing-output
- (format nil "~A~{ ~A~}" command arglist)
- :output-stream s :prefix "" :show-cmd nil)
- (get-output-stream-string s))))
-
-;;; Do we really want to suppress the output by default?
-(defun invoke (command &rest args)
- (when (pathnamep command)
- (setf command (cffi-sys:native-namestring command)))
- (format *debug-io* "; ~A~{ ~A~}~%" command args)
- (multiple-value-bind (exit-code output)
- (%invoke command args)
- (unless (zerop exit-code)
- (grovel-error "External process exited with code ~S.~@
- Command was: ~S~{ ~S~}~@
- Output was:~%~A"
- exit-code command args output))
- output))
--
2.6.0.rc0.131.gf624c3d
