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
177
178
|
;;;; -*- 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")))
)
|
