os.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          os.lisp
   6 ;;;; Purpose:       Operating System utilities
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Jul 2003
   9 ;;;;
  10 ;;;; $Id$
  11 ;;;;
  12 ;;;; *************************************************************************
  13
  14 (in-package #:kmrcl)
  15
  16 (defun command-output (control-string &rest args)
  17   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
  18 synchronously execute the result using a Bourne-compatible shell,
  19 returns (VALUES string-output error-output exit-status)"
  20   (let ((command (apply #'format nil control-string args)))
  21     #+sbcl
  22     (let* ((process (sb-ext:run-program
  23                     "/bin/sh"
  24                     (list "-c" command)
  25                     :input nil :output :stream :error :stream))
  26            (output (read-stream-to-string (sb-impl::process-output process)))
  27            (error (read-stream-to-string (sb-impl::process-error process))))
  28       (close (sb-impl::process-output process))
  29       (close (sb-impl::process-error process))
  30       (values
  31        output
  32        error
  33        (sb-impl::process-exit-code process)))
  34
  35
  36     #+(or cmu scl)
  37     (let* ((process (ext:run-program
  38                      "/bin/sh"
  39                      (list "-c" command)
  40                      :input nil :output :stream :error :stream))
  41            (output (read-stream-to-string (ext::process-output process)))
  42            (error (read-stream-to-string (ext::process-error process))))
  43       (close (ext::process-output process))
  44       (close (ext::process-error process))
  45
  46       (values
  47        output
  48        error
  49        (ext::process-exit-code process)))
  50
  51     #+allegro
  52     (multiple-value-bind (output error status)
  53         (excl.osi:command-output command :whole t)
  54       (values output error status))
  55
  56     #+lispworks
  57     ;; BUG: Lispworks combines output and error streams
  58     (let ((output (make-string-output-stream)))
  59       (unwind-protect
  60           (let ((status
  61                  (system:call-system-showing-output
  62                   command
  63                   :shell-type "/bin/sh"
  64                   :output-stream output)))
  65             (values (get-output-stream-string output) nil status))
  66         (close output)))
  67
  68     #+clisp
  69     ;; BUG: CLisp doesn't allow output to user-specified stream
  70     (values
  71      nil
  72      nil
  73      (ext:run-shell-command  command :output :terminal :wait t))
  74
  75     #+openmcl
  76     (let* ((process (ccl:run-program
  77                      "/bin/sh"
  78                      (list "-c" command)
  79                      :input nil :output :stream :error :stream
  80                      :wait t))
  81            (output (read-stream-to-string (ccl::external-process-output-stream process)))
  82            (error (read-stream-to-string (ccl::external-process-error-stream process))))
  83       (close (ccl::external-process-output-stream process))
  84       (close (ccl::external-process-error-stream process))
  85       (values output
  86               error
  87               (nth-value 1 (ccl::external-process-status process))))
  88
  89     #-(or openmcl clisp lispworks allegro scl cmu sbcl)
  90     (error "COMMAND-OUTPUT not implemented for this Lisp")
  91
  92     ))
  93
  94 (defun run-shell-command (control-string &rest args)
  95   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
  96 synchronously execute the result using a Bourne-compatible shell,
  97 returns (VALUES output-string pid)"
  98   (let ((command (apply #'format nil control-string args)))
  99     #+sbcl
 100     (sb-impl::process-exit-code
 101      (sb-ext:run-program
 102       "/bin/sh"
 103       (list  "-c" command)
 104       :input nil :output nil))
 105
 106     #+(or cmu scl)
 107     (ext:process-exit-code
 108      (ext:run-program
 109       "/bin/sh"
 110       (list  "-c" command)
 111       :input nil :output nil))
 112
 113
 114     #+allegro
 115     (excl:run-shell-command command :input nil :output nil
 116                             :wait t)
 117
 118     #+lispworks
 119     (system:call-system-showing-output
 120      command
 121      :shell-type "/bin/sh"
 122      :output-stream output)
 123
 124     #+clisp             ;XXX not exactly *verbose-out*, I know
 125     (ext:run-shell-command  command :output :terminal :wait t)
 126
 127     #+openmcl
 128     (nth-value 1
 129                (ccl:external-process-status
 130                 (ccl:run-program "/bin/sh" (list "-c" command)
 131                                  :input nil :output nil
 132                                  :wait t)))
 133
 134     #-(or openmcl clisp lispworks allegro scl cmu sbcl)
 135     (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
 136
 137     ))