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                   :prefix ""
  64                   :show-cmd nil
  65                   :output-stream output)))
  66             (values (get-output-stream-string output) nil status))
  67         (close output)))
  68
  69     #+clisp
  70     ;; BUG: CLisp doesn't allow output to user-specified stream
  71     (values
  72      nil
  73      nil
  74      (ext:run-shell-command  command :output :terminal :wait t))
  75
  76     #+openmcl
  77     (let* ((process (ccl:run-program
  78                      "/bin/sh"
  79                      (list "-c" command)
  80                      :input nil :output :stream :error :stream
  81                      :wait t))
  82            (output (read-stream-to-string (ccl::external-process-output-stream process)))
  83            (error (read-stream-to-string (ccl::external-process-error-stream process))))
  84       (close (ccl::external-process-output-stream process))
  85       (close (ccl::external-process-error-stream process))
  86       (values output
  87               error
  88               (nth-value 1 (ccl::external-process-status process))))
  89
  90     #-(or openmcl clisp lispworks allegro scl cmu sbcl)
  91     (error "COMMAND-OUTPUT not implemented for this Lisp")
  92
  93     ))
  94
  95 (defun run-shell-command (control-string &rest args)
  96   "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
  97 synchronously execute the result using a Bourne-compatible shell,
  98 returns (VALUES output-string pid)"
  99   (let ((command (apply #'format nil control-string args)))
 100     #+sbcl
 101     (sb-impl::process-exit-code
 102      (sb-ext:run-program
 103       "/bin/sh"
 104       (list  "-c" command)
 105       :input nil :output nil))
 106
 107     #+(or cmu scl)
 108     (ext:process-exit-code
 109      (ext:run-program
 110       "/bin/sh"
 111       (list  "-c" command)
 112       :input nil :output nil))
 113
 114
 115     #+allegro
 116     (excl:run-shell-command command :input nil :output nil
 117                             :wait t)
 118
 119     #+lispworks
 120     (system:call-system-showing-output
 121      command
 122      :shell-type "/bin/sh"
 123      :show-cmd nil
 124      :prefix ""
 125      :output-stream nil)
 126
 127     #+clisp             ;XXX not exactly *verbose-out*, I know
 128     (ext:run-shell-command  command :output :terminal :wait t)
 129
 130     #+openmcl
 131     (nth-value 1
 132                (ccl:external-process-status
 133                 (ccl:run-program "/bin/sh" (list "-c" command)
 134                                  :input nil :output nil
 135                                  :wait t)))
 136
 137     #-(or openmcl clisp lispworks allegro scl cmu sbcl)
 138     (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
 139
 140     ))
 141
 142 (defun delete-directory-and-files (dir &key (if-does-not-exist :error) (quiet t) force)
 143   #+allegro (excl:delete-directory-and-files dir :if-does-not-exist if-does-not-exist
 144                                              :quiet quiet :force force)
 145   #-(or allegro) (declare (ignore force))
 146   #-(or allegro) (cond
 147                    ((probe-directory dir)
 148                     (let ((cmd (format nil "rm -rf ~A" (namestring dir))))
 149                       (unless quiet
 150                         (format *trace-output* ";; ~A" cmd))
 151                       (command-output cmd)))
 152                    ((eq if-does-not-exist :error)
 153                     (error "Directory ~A does not exist [delete-directory-and-files]." dir))))
 154
 155 (defun file-size (file)
 156   (when (probe-file file)
 157     #+allegro (let ((stat (excl.osi:stat (namestring file))))
 158                 (excl.osi:stat-size stat))
 159     #-allegro
 160     (with-open-file (in file :direction :input)
 161       (file-length in))))