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