src/grovel/invoke.lisp

   1 ;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; invoke.lisp --- Half-baked portable run-program.
   4 ;;;
   5 ;;; Copyright (C) 2005-2006, Dan Knap <dankna@accela.net>
   6 ;;; Copyright (C) 2005-2006, Emily Backes <lucca@accela.net>
   7 ;;; Copyright (C) 2007, Stelian Ionescu <sionescu@cddr.org>
   8 ;;; Copyright (C) 2007, Luis Oliveira <loliveira@common-lisp.net>
   9 ;;;
  10 ;;; Permission is hereby granted, free of charge, to any person
  11 ;;; obtaining a copy of this software and associated documentation
  12 ;;; files (the "Software"), to deal in the Software without
  13 ;;; restriction, including without limitation the rights to use, copy,
  14 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
  15 ;;; of the Software, and to permit persons to whom the Software is
  16 ;;; furnished to do so, subject to the following conditions:
  17 ;;;
  18 ;;; The above copyright notice and this permission notice shall be
  19 ;;; included in all copies or substantial portions of the Software.
  20 ;;;
  21 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
  22 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
  23 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
  24 ;;; NONINFRINGEMENT.  IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
  25 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
  26 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  27 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  28 ;;; DEALINGS IN THE SOFTWARE.
  29 ;;;
  30
  31 (in-package #:iolib-grovel)
  32
  33 ;;;# Shell Execution
  34
  35 #-(or abcl allegro clisp cmu ecl lispworks openmcl sbcl scl)
  36 (error "%INVOKE is unimplemented for this Lisp.  Patches welcome.")
  37
  38 ;; FIXME: doesn't do shell quoting
  39 #+abcl
  40 (defun %invoke (command arglist)
  41   (let ((cmdline (reduce (lambda (str1 str2)
  42                            (concatenate 'string str1 " " str2))
  43                          arglist :initial-value command))
  44         (stream (make-string-output-stream)))
  45     (values (ext:run-shell-command cmdline :output stream)
  46             (get-output-stream-string stream))))
  47
  48 ;;; FIXME: As best I can tell CLISP's EXT:RUN-PROGRAM can either
  49 ;;; create new streams OR return the exit code, but not both.  Using
  50 ;;; existing streams doesn't seem to be an option either.
  51 #+clisp
  52 (defun %invoke (command arglist)
  53   (let ((ret (ext:run-program command :arguments arglist)))
  54     (values (etypecase ret
  55               ((eql nil) 0)
  56               ((eql   t) 1)
  57               (integer   ret))
  58             "<see above>")))
  59
  60 #+ecl
  61 (defun %invoke (command arglist)
  62   (values
  63    (nth-value 1 (ext:run-program "/bin/sh"
  64                                  (list "-c"
  65                                        (format nil "~A~{ ~A~}" command arglist))
  66                                  :wait t :output nil :input nil :error nil))
  67    "<see above>"))
  68
  69 #+(or openmcl cmu scl sbcl)
  70 (defun %invoke (command arglist)
  71   (let* ((exit-code)
  72          (output
  73           (with-output-to-string (s)
  74             (let ((process (#+openmcl ccl:run-program
  75                             #+(or cmu scl) ext:run-program
  76                             #+sbcl sb-ext:run-program
  77                             command arglist #-win32 :output #-win32 s
  78                             :error :output
  79                             #+sbcl :search #+sbcl t)))
  80               #+win32
  81               (write-line "note: SBCL on windows can't redirect output.")
  82               (setq exit-code
  83                     #+openmcl (nth-value
  84                                1 (ccl:external-process-status process))
  85                     #+sbcl (sb-ext:process-exit-code process)
  86                     #+(or cmu scl) (ext:process-exit-code process))))))
  87     (values exit-code output)))
  88
  89 #+allegro
  90 (defun %invoke (command arglist)
  91   (let ((cmd #-mswindows (concatenate 'vector (list command command) arglist)
  92              #+mswindows (format nil "~A~{ ~A~}" command arglist)))
  93     (multiple-value-bind (output error-output exit-code)
  94         (excl.osi:command-output cmd :whole t)
  95       (declare (ignore error-output))
  96       (values exit-code output))))
  97
  98 ;;; FIXME: Runs shell, and arguments are unquoted.
  99 #+lispworks
 100 (defun %invoke (command arglist)
 101   (let ((s (make-string-output-stream)))
 102     (values (sys:call-system-showing-output
 103              (format nil "~A~{ ~A~}" command arglist)
 104              :output-stream s :prefix "" :show-cmd nil)
 105             (get-output-stream-string s))))
 106
 107 ;;; Do we really want to suppress the output by default?
 108 (defun invoke (command &rest args)
 109   (when (pathnamep command)
 110     (setf command (cffi-sys:native-namestring command)))
 111   (format *debug-io* "; ~A~{ ~A~}~%" command args)
 112   (multiple-value-bind (exit-code output)
 113       (%invoke command args)
 114     (unless (zerop exit-code)
 115       (error "External process exited with code ~S.~@
 116               Command was: ~S~{ ~S~}~@
 117               Output was:~%~A"
 118              exit-code command args output))))