-
Notifications
You must be signed in to change notification settings - Fork 6
/
Copy pathexec.lisp
236 lines (202 loc) · 7.58 KB
/
exec.lisp
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
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
;; exec.lisp -- a collection of routines to support synchronous spawning of
;; external processes...
;;
;; DM/MCFA 07/01
(defpackage "EXEC"
(:use "COMMON-LISP")
(:export
"EXEC"
"EXEC-AND-WAIT-PROCESS"
"SYSTEM"))
(in-package "EXEC")
;; ShowWindow() Commands
(eval-when (:compile-toplevel :load-toplevel :execute)
(um:def-enum
SW_HIDE
SW_SHOWNORMAL
(SW_NORMAL SW_SHOWNORMAL)
SW_SHOWMINIMIZED
SW_SHOWMAXIMIZED
(SW_MAXIMIZE SW_SHOWMAXIMIZED)
SW_SHOWNOACTIVATE
SW_SHOW
SW_MINIMIZE
SW_SHOWMINNOACTIVE
SW_SHOWNA
SW_RESTORE
SW_SHOWDEFAULT
(SW_MAX SW_SHOWDEFAULT))
)
(um:ez-define-foreign-function (%winexec "WinExec")
((app-name ct:out-cstring)
(startup-state :int))
;; :encoding :object
:result-type :int
:calling-convention :stdcall
:module "Kernel32.dll")
(defun winexec (cmd &optional (window-state SW_SHOWNORMAL))
(if (<= (%winexec cmd window-state) 31)
(error "Can't start Windows app: ~A" cmd)))
(fli:define-c-struct startup-info
(cb :int)
(lpReserved :int) ;; must be zero
(lpDesktop :int) ;; make it zero
(lpTitle :int) ;; make it zero
(dwX :int)
(dwY :int)
(dwXSize :int)
(dwYSize :int)
(dwXCountChars :int)
(dwYCountChars :int)
(dwFillAttribute :int)
(dwFlags :int)
(wShowWindow :int)
(cbReserved2 :int) ;; must be zero
(lpReserved2 :int) ;; must be zero
(hStdInput :int)
(hStdOutput :int)
(hStdError :int)
)
;;
;; dwFlags values
;;
(defconstant STARTF_USESHOWWINDOW #x00000001)
(defconstant STARTF_USESIZE #x00000002)
(defconstant STARTF_USEPOSITION #x00000004)
(defconstant STARTF_USECOUNTCHARS #x00000008)
(defconstant STARTF_USEFILLATTRIBUTE #x00000010)
(defconstant STARTF_RUNFULLSCREEN #x00000020)
(defconstant STARTF_FORCEONFEEDBACK #x00000040)
(defconstant STARTF_FORCEOFFFEEDBACK #x00000080)
(defconstant STARTF_USESTDHANDLES #x00000100)
(defconstant STARTF_USEHOTKEY #x00000200)
(fli:define-c-struct proc-info
(hProcess :int)
(hThread :int)
(dwProcID :int)
(dwThreadID :int)
)
;;
;; startup flags
;;
(defconstant DEBUG_PROCESS #x00000001)
(defconstant DEBUG_ONLY_THIS_PROCESS #x00000002)
(defconstant CREATE_SUSPENDED #x00000004)
(defconstant DETACHED_PROCESS #x00000008)
(defconstant CREATE_NEW_CONSOLE #x00000010)
(defconstant NORMAL_PRIORITY_CLASS #x00000020)
(defconstant IDLE_PRIORITY_CLASS #x00000040)
(defconstant HIGH_PRIORITY_CLASS #x00000080)
(defconstant REALTIME_PRIORITY_CLASS #x00000100)
(defconstant CREATE_NEW_PROCESS_GROUP #x00000200)
(defconstant CREATE_UNICODE_ENVIRONMENT #x00000400)
(defconstant CREATE_SEPARATE_WOW_VDM #x00000800)
(defconstant CREATE_SHARED_WOW_VDM #x00001000)
(defconstant CREATE_FORCEDOS #x00002000)
(defconstant CREATE_DEFAULT_ERROR_MODE #x04000000)
(defconstant CREATE_NO_WINDOW #x08000000)
(defconstant PROFILE_USER #x10000000)
(defconstant PROFILE_KERNEL #x20000000)
(defconstant PROFILE_SERVER #x40000000)
(um:ez-define-foreign-function (%createprocess "CreateProcessA")
((appname ct:out-cstring) ;; will pick it up from cmdline if null
(cmdline ct:out-cstring)
(:constant 0 :int) ;; proc-tr
(:constant 0 :int) ;; tread-attr
(:constant 0 :int) ;; no inherit handles...
(:constant CREATE_NEW_CONSOLE :int) ;; creation flags
(:constant 0 :int) ;; inherit our environ
(currdir ct:out-cstring) ;; will use our dir if null
(srtinfo (:pointer startup-info))
(procinf (:pointer proc-info))
)
:result-type :int
:calling-convention :stdcall
:module "Kernel32.dll")
(defun make-startup-info ()
;; must be called inside a "with-dynamic-foreign-objects" clause.
;; caller must coerce to a startup-info pointer
(let* ((info (fli:allocate-dynamic-foreign-object
:type :int
:nelems (/ (fli:size-of 'startup-info) (fli:size-of :int))
:initial-element 0)))
(fli:with-coerced-pointer (p :type 'startup-info) info
(setf (fli:foreign-slot-value p 'cb) (fli:size-of 'startup-info)
(fli:foreign-slot-value p 'dwFlags) STARTF_USESHOWWINDOW
(fli:foreign-slot-value p 'wShowWindow) SW_SHOWNORMAL
))
info))
(defun exec (cmd &key appname directory)
"Execute a command line as another process. Returns immediately
with a keylist of Win32 process information."
(fli:with-dynamic-foreign-objects ()
(let* ((start-info (make-startup-info))
(proc-info (fli:allocate-dynamic-foreign-object
:type 'proc-info)))
(fli:with-coerced-pointer (p :type 'startup-info) start-info
(if (zerop (%createprocess appname cmd directory p proc-info))
(error "~%Can't exec command: ~A" cmd)
(list :hProcess (fli:foreign-slot-value proc-info 'hProcess)
:hThread (fli:foreign-slot-value proc-info 'hThread)
:dwProcID (fli:foreign-slot-value proc-info 'dwProcID)
:dwThreadID (fli:foreign-slot-value proc-info 'dwThreadID))
))
)))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defconstant SYNCHRONIZE #x00100000)
(defconstant STANDARD_RIGHTS_REQUIRED #x000F0000)
(defconstant PROCESS_QUERY_INFORMATION #x0400)
)
(fli:define-foreign-function (%openProcess "OpenProcess")
((:constant #.(+ PROCESS_QUERY_INFORMATION SYNCHRONIZE) :int)
(:constant 0 :int)
(dwProcessID :int))
:result-type :int
:calling-convention :stdcall
:module "Kernel32.dll")
(fli:define-foreign-function (%closeHandle "CloseHandle")
((handle :int))
:result-type :int
:calling-convention :stdcall
:module "Kernel32.dll")
(fli:define-foreign-function (%getExitCodeProcess "GetExitCodeProcess")
((hProcess :int)
(lpExitCode (:pointer :int)))
:result-type :int
:calling-convention :stdcall
:module "Kernel32.dll")
(defun getExitCodeProcess (hProcess)
(fli:with-dynamic-foreign-objects ()
(let ((code (fli:allocate-dynamic-foreign-object
:type :int
:nelems 1
:initial-element 0)))
(%getExitCodeProcess hProcess code)
(fli:dereference code))))
(fli:define-foreign-function (%waitForSingleObject "WaitForSingleObject")
((handle :int)
(dwMilliseconds :int))
:result-type :int
:calling-convention :stdcall
:module "Kernel32.dll")
(defconstant INFINITE -1)
(defun waitForSingleObject (handle &optional (timeoutMilliseconds INFINITE))
(%waitForSingleObject handle timeoutMilliseconds))
(defun exec-and-wait-process (cmd &rest args)
"Call EXEC on the command line and wait for the process to terminate.
Returns the process exit code."
(let* ((info (apply 'exec cmd args))
(handle (%openProcess (getf info :dwProcID))))
(unwind-protect
(progn
(waitForSingleObject handle)
(getExitCodeProcess handle))
(%closeHandle handle))))
;; ------------------------------------------------
(defconstant **lisp-com-lib** "lispcom.dll")
(um:ez-define-foreign-function (system "_LispSystemCall@4")
((cmd ct:out-cstring))
:result-type :int
:calling-convention :stdcall
:module **lisp-com-lib**)
;; -- end of exec.lisp -- ;;