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 ;;; FIXME: there's no way to tell from EXT:RUN-PROGRAM whether the
  61 ;;; command failed or not.  Using EXT:SYSTEM instead, but we should
  62 ;;; quote arguments.
  63 #+ecl
  64 (defun %invoke (command arglist)
  65   (values (ext:system (format nil "~A~{ ~A~}" command arglist))
  66           "<see above>"))
  67
  68 #+(or openmcl cmu scl sbcl)
  69 (defun %invoke (command arglist)
  70   (let* ((exit-code)
  71          (output
  72           (with-output-to-string (s)
  73             (let ((process (#+openmcl ccl:run-program
  74                             #+(or cmu scl) ext:run-program
  75                             #+sbcl sb-ext:run-program
  76                             command arglist #-win32 :output #-win32 s
  77                             :error :output
  78                             #+sbcl :search #+sbcl t)))
  79               #+win32
  80               (write-line "note: SBCL on windows can't redirect output.")
  81               (setq exit-code
  82                     #+openmcl (nth-value
  83                                1 (ccl:external-process-status process))
  84                     #+sbcl (sb-ext:process-exit-code process)
  85                     #+(or cmu scl) (ext:process-exit-code process))))))
  86     (values exit-code output)))
  87
  88 #+allegro
  89 (defun %invoke (command arglist)
  90   (let ((cmd #-mswindows (concatenate 'vector (list command command) arglist)
  91              #+mswindows (format nil "~A~{ ~A~}" command arglist)))
  92     (multiple-value-bind (output error-output exit-code)
  93         (excl.osi:command-output cmd :whole t)
  94       (declare (ignore error-output))
  95       (values exit-code output))))
  96
  97 ;;; FIXME: Runs shell, and arguments are unquoted.
  98 #+lispworks
  99 (defun %invoke (command arglist)
 100   (let ((s (make-string-output-stream)))
 101     (values (sys:call-system-showing-output
 102              (format nil "~A~{ ~A~}" command arglist)
 103              :output-stream s :prefix "" :show-cmd nil)
 104             (get-output-stream-string s))))
 105
 106 ;;; Do we really want to suppress the output by default?
 107 (defun invoke (command &rest args)
 108   (when (pathnamep command)
 109     (setf command (cffi-sys:native-namestring command)))
 110   (format *debug-io* "; ~A~{ ~A~}~%" command args)
 111   (multiple-value-bind (exit-code output)
 112       (%invoke command args)
 113     (unless (zerop exit-code)
 114       (error "External process exited with code ~S.~@
 115               Command was: ~S~{ ~S~}~@
 116               Output was:~%~A"
 117              exit-code command args output))))