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 ;;;; *************************************************************************
  11
  12 (in-package #:kmrcl)
  13
  14 (defun command-output (control-string &rest args)
  15   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
  16 synchronously execute the result using a Bourne-compatible shell,
  17 returns (VALUES string-output error-output exit-status)"
  18   (let ((command (apply #'format nil control-string args)))
  19     #+sbcl
  20     (let* ((process (sb-ext:run-program
  21                     "/bin/sh"
  22                     (list "-c" command)
  23                     :input nil :output :stream :error :stream))
  24            (output (read-stream-to-string (sb-impl::process-output process)))
  25            (error (read-stream-to-string (sb-impl::process-error process))))
  26       (close (sb-impl::process-output process))
  27       (close (sb-impl::process-error process))
  28       (values
  29        output
  30        error
  31        (sb-impl::process-exit-code process)))
  32
  33
  34     #+(or cmu scl)
  35     (let* ((process (ext:run-program
  36                      "/bin/sh"
  37                      (list "-c" command)
  38                      :input nil :output :stream :error :stream))
  39            (output (read-stream-to-string (ext::process-output process)))
  40            (error (read-stream-to-string (ext::process-error process))))
  41       (close (ext::process-output process))
  42       (close (ext::process-error process))
  43
  44       (values
  45        output
  46        error
  47        (ext::process-exit-code process)))
  48
  49     #+allegro
  50     (multiple-value-bind (output error status)
  51         (excl.osi:command-output command :whole t)
  52       (values output error status))
  53
  54     #+lispworks
  55     ;; BUG: Lispworks combines output and error streams
  56     (let ((output (make-string-output-stream)))
  57       (unwind-protect
  58           (let ((status
  59                  (system:call-system-showing-output
  60                   command
  61                   :prefix ""
  62                   :show-cmd nil
  63                   :output-stream output)))
  64             (values (get-output-stream-string output) nil status))
  65         (close output)))
  66
  67     #+clisp
  68     ;; BUG: CLisp doesn't allow output to user-specified stream
  69     (values
  70      nil
  71      nil
  72      (ext:run-shell-command  command :output :terminal :wait t))
  73
  74     #+openmcl
  75     (let* ((process (ccl:run-program
  76                      "/bin/sh"
  77                      (list "-c" command)
  78                      :input nil :output :stream :error :stream
  79                      :wait t))
  80            (output (read-stream-to-string (ccl::external-process-output-stream process)))
  81            (error (read-stream-to-string (ccl::external-process-error-stream process))))
  82       (close (ccl::external-process-output-stream process))
  83       (close (ccl::external-process-error-stream process))
  84       (values output
  85               error
  86               (nth-value 1 (ccl::external-process-status process))))
  87
  88     #-(or openmcl clisp lispworks allegro scl cmu sbcl)
  89     (error "COMMAND-OUTPUT not implemented for this Lisp")
  90
  91     ))
  92
  93 (defun run-shell-command (control-string &rest args)
  94   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
  95 synchronously execute the result using a Bourne-compatible shell,
  96 returns (VALUES output-string pid)"
  97   (let ((command (apply #'format nil control-string args)))
  98     #+sbcl
  99     (sb-impl::process-exit-code
 100      (sb-ext:run-program
 101       "/bin/sh"
 102       (list  "-c" command)
 103       :input nil :output nil))
 104
 105     #+(or cmu scl)
 106     (ext:process-exit-code
 107      (ext:run-program
 108       "/bin/sh"
 109       (list  "-c" command)
 110       :input nil :output nil))
 111
 112
 113     #+allegro
 114     (excl:run-shell-command command :input nil :output nil
 115                             :wait t)
 116
 117     #+lispworks
 118     (system:call-system-showing-output
 119      command
 120      :shell-type "/bin/sh"
 121      :show-cmd nil
 122      :prefix ""
 123      :output-stream nil)
 124
 125     #+clisp             ;XXX not exactly *verbose-out*, I know
 126     (ext:run-shell-command  command :output :terminal :wait t)
 127
 128     #+openmcl
 129     (nth-value 1
 130                (ccl:external-process-status
 131                 (ccl:run-program "/bin/sh" (list "-c" command)
 132                                  :input nil :output nil
 133                                  :wait t)))
 134
 135     #-(or openmcl clisp lispworks allegro scl cmu sbcl)
 136     (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
 137
 138     ))
 139
 140 (defun delete-directory-and-files (dir &key (if-does-not-exist :error) (quiet t) force)
 141   #+allegro (excl:delete-directory-and-files dir :if-does-not-exist if-does-not-exist
 142                                              :quiet quiet :force force)
 143   #-(or allegro) (declare (ignore force))
 144   #-(or allegro) (cond
 145                    ((probe-directory dir)
 146                     (let ((cmd (format nil "rm -rf ~A" (namestring dir))))
 147                       (unless quiet
 148                         (format *trace-output* ";; ~A" cmd))
 149                       (command-output cmd)))
 150                    ((eq if-does-not-exist :error)
 151                     (error "Directory ~A does not exist [delete-directory-and-files]." dir))))
 152
 153 (defun file-size (file)
 154   (when (probe-file file)
 155     #+allegro (let ((stat (excl.osi:stat (namestring file))))
 156                 (excl.osi:stat-size stat))
 157     #+sbcl (sb-posix:stat-size (sb-posix:stat file))
 158     #-(or allegro sbcl)
 159     (with-open-file (in file :direction :input)
 160       (file-length in))))
 161
 162 (defun getpid ()
 163   "Return the PID of the lisp process."
 164   #+allegro (excl::getpid)
 165   #+(and lispworks win32) (win32:get-current-process-id)
 166   #+(and lispworks (not win32)) (system::getpid)
 167   #+sbcl (sb-posix:getpid)
 168   #+cmu (unix:unix-getpid)
 169   #+openmcl (ccl::getpid)
 170   #+(and clisp unix) (system::process-id)
 171   #+(and clisp win32) (cond ((find-package :win32)
 172                              (funcall (find-symbol "GetCurrentProcessId"
 173                                                    :win32)))
 174                             (t
 175                              (system::getenv "PID")))
 176   )
 177
 178