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
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
|
;;;; Running external programs
(in-package "EXT")
#+WIN32 (export '(execute))
#+(or UNIX WIN32) (export '(run-shell-command run-program))
(in-package "SYSTEM")
;;-----------------------------------------------------------------------------
#+(or UNIX WIN32)
;; UNIX:
; Must quote the program name and arguments since Unix shells interpret
; characters like #\Space, #\', #\<, #\>, #\$ etc. in a special way. This
; kind of quoting should work unless the string contains #\Newline and we
; call csh. But we are lucky: only /bin/sh will be used.
;; WIN32:
; Must quote program name and arguments since Win32 interprets characters
; like #\Space, #\Tab, #\\, #\" (but not #\< and #\>) in a special way:
; - Space and Tab are interpreted as delimiters. They are not treated as
; delimiters if they are surrounded by double quotes: "...".
; - Unescaped double quotes are removed from the input. Their only effect is
; that within double quotes, space and tab are treated like normal characters.
; - Backslashes not followed by double quotes are not special.
; - But 2*n+1 backslashes followed by a double quote become
; n backslashes followed by a double quote (n >= 0):
; \" -> "
; \\\" -> \"
; \\\\\" -> \\"
; The high-level Win32 command interpreter cmd.exe (but not the low-level
; function CreateProcess()) also interprets #\&, #\<, #\>, #\| as special
; delimiters and makes #\^ disappear. To avoid this, quote them like spaces.
(labels (#+UNIX
(shell-simple-quote (string)
(shell-quote string)
)
#+UNIX
(shell-quote (string) ; surround a string by single quotes
(if (eql (length string) 0)
"''"
(let ((qchar nil) ; last quote character: nil or #\' or #\"
(qstring (make-array 10 :element-type 'character
:adjustable t :fill-pointer 0)))
(map nil #'(lambda (c)
(let ((q (if (eql c #\') #\" #\')))
(unless (eql qchar q)
(when qchar (vector-push-extend qchar qstring))
(vector-push-extend (setq qchar q) qstring)
)
(vector-push-extend c qstring)))
string
)
(when qchar (vector-push-extend qchar qstring))
qstring
) ) )
#+WIN32
(shell-simple-quote (string) ; protect against spaces only
; Also protect the characters which are special for the command
; interpreter. This is needed only if the command interpreter
; will be called, but doesn't hurt if CreateProcess() will be
; called directly.
(if (or (eql (length string) 0)
(some #'(lambda (c)
(or ; space?
(<= (char-code c) 32)
; special delimiter?
(eql c #\&)
(eql c #\<)
(eql c #\>)
(eql c #\|)
(eql c #\^)
) )
string
) )
(string-concat "\"" string "\"")
string
) )
#+WIN32
(shell-quote (string) ; full protection
(let ((quote-around
(or (eql (length string) 0)
(some #'(lambda (c)
(or ; space?
(<= (char-code c) 32)
; special delimiter?
(eql c #\&)
(eql c #\<)
(eql c #\>)
(eql c #\|)
(eql c #\^)
) )
string)))
(qstring (make-array 10 :element-type 'character
:adjustable t :fill-pointer 0))
(backslashes 0))
(when quote-around
(vector-push-extend #\" qstring)
)
(map nil #'(lambda (c)
(when (eql c #\")
(dotimes (i (+ backslashes 1))
(vector-push-extend #\\ qstring)
) )
(vector-push-extend c qstring)
(if (eql c #\\)
(incf backslashes)
(setq backslashes 0)
) )
string
)
(when quote-around
(dotimes (i backslashes)
(vector-push-extend #\\ qstring)
)
(vector-push-extend #\" qstring)
)
qstring
) )
; conversion to a string that works for a pathname as well
(xstring (object)
(if (pathnamep object)
(namestring (absolute-pathname object))
(if (symbolp object)
(princ-to-string object)
(string object)))))
#+WIN32
(defun execute (programfile &rest arguments)
(shell
(apply #'string-concat
(shell-simple-quote (xstring programfile))
(mapcan #'(lambda (argument)
(list " " (shell-quote (xstring argument)))
)
arguments
) ) ) )
(defun run-shell-command (command &key (input ':terminal) (output ':terminal)
(if-output-exists ':overwrite)
(wait t)
#+UNIX (may-exec nil)
#+WIN32 (indirectp t)
)
(case input
((:TERMINAL :STREAM) )
(t (if (eq input 'NIL)
(setq input #+UNIX "/dev/null" #+WIN32 "nul")
(setq input (xstring input))
)
(setq command (string-concat command " < " (shell-quote input)))
#+WIN32 (setq indirectp t)
) )
(case output
((:TERMINAL :STREAM) )
(t (if (eq output 'NIL)
(setq output #+UNIX "/dev/null" #+WIN32 "nul"
if-output-exists ':OVERWRITE
)
(progn
(setq output (xstring output))
(when (and (eq if-output-exists ':ERROR) (probe-file output))
(setq output (pathname output))
(error-of-type 'file-error
:pathname output
(TEXT "~S: File ~S already exists")
'run-shell-command output
) ) ) )
(setq command
(string-concat command
(ecase if-output-exists
((:OVERWRITE :ERROR) " > ")
(:APPEND " >> ")
)
(shell-quote output)
) )
#+WIN32 (setq indirectp t)
) )
#-WIN32
(unless wait
(setq command (string-concat command " &")))
#+WIN32
(unless wait
(setq indirectp t)
(setf command (string-concat "start " command)))
#+UNIX
(when may-exec
; Wenn die ausführende Shell die "/bin/sh" ist und command eine
; "simple command" im Sinne von sh(1), können wir ein wenig optimieren:
(setq command (string-concat "exec " command))
)
#+WIN32
(when indirectp
(setq command (string-concat (shell-name) " /c " command))
)
(if (eq input ':STREAM)
(if (eq output ':STREAM)
(make-pipe-io-stream command)
(make-pipe-output-stream command)
)
(if (eq output ':STREAM)
(make-pipe-input-stream command)
(shell command) ; unter UNIX evtl. " &" anfügen, um Hintergrund-Prozess zu bekommen
) )
)
(defun run-program (program &key (arguments '())
(input ':terminal) (output ':terminal)
(if-output-exists ':overwrite)
(wait t)
#+WIN32 (indirectp nil)
)
(run-shell-command
(apply #'string-concat
(shell-simple-quote (xstring program))
(mapcan #'(lambda (argument)
(list " " (shell-quote (xstring argument)))
)
arguments
) )
#+UNIX :may-exec #+UNIX t
#+WIN32 :indirectp #+WIN32 indirectp
:wait wait
:input input :output output :if-output-exists if-output-exists
) )
)
|
