/quick-test/call.r

  1REBOL [
  2	Name: "CALL for Win32"
  3	Author: "Nenad Rakocevic"
  4	Purpose: "Blocking execution of external commands for Windows OS"
  5]
  6
  7context [
  8	kernel32: load/library %kernel32.dll
  9
 10	SECURITY_ATTRIBUTES: make struct! [
 11		nLength 			 [integer!]
 12		lpSecurityDescriptor [integer!]
 13		bInheritHandle 		 [integer!]
 14	] none
 15
 16	STARTUPINFO: make struct! startup-info-struct: [
 17		cb 				[integer!]
 18		lpReserved 		[integer!]
 19		lpDesktop		[integer!]
 20		lpTitle			[integer!]
 21		dwX				[integer!]
 22		dwY				[integer!]
 23		dwXSize			[integer!]
 24		dwYSize			[integer!]
 25		dwXCountChars 	[integer!]
 26		dwYCountChars 	[integer!]
 27		dwFillAttribute	[integer!]
 28		dwFlags			[integer!]
 29		wShowWindow		[short]
 30		cbReserved2		[short]
 31		lpReserved2		[integer!]
 32		hStdInput		[integer!]
 33		hStdOutput		[integer!]
 34		hStdError		[integer!]
 35	] none
 36
 37	PROCESS_INFORMATION: make struct! [
 38		hProcess	[integer!]
 39		hThread 	[integer!]
 40		dwProcessID	[integer!]
 41		dwThreadID	[integer!]
 42	] none
 43
 44	CreatePipe: make routine!  [
 45		phReadPipe 		 [struct! [num [integer!]]]
 46		phWritePipe 	 [struct! [num [integer!]]]
 47		lpPipeAttributes [struct! [a [integer!] b [integer!] c [integer!]]]
 48		nSize 			 [integer!]
 49		return:			 [integer!]
 50	] kernel32 "CreatePipe"
 51
 52	ReadFile: make routine! [
 53		hFile 				 [integer!]
 54		lpBuffer 			 [string!]
 55		nNumberOfBytesToRead [integer!]
 56		lpNumberOfBytesRead  [struct! [num [integer!]]]
 57		lpOverlapped 		 [integer!]
 58		return:				 [integer!]
 59	] kernel32 "ReadFile"
 60	
 61	PeekNamedPipe: make routine! [
 62		hNamedPipe			[integer!]
 63		lpBuffer			[integer!]
 64		nBufferSize			[integer!]
 65		lpBytesRead			[integer!]
 66		lpTotalBytesAvail	[struct! [cnt [integer!]]]
 67		lpBytesLeftThisMessage [integer!]
 68		return: 			[integer!]
 69	] kernel32 "PeekNamedPipe"
 70	
 71	WriteFile: make routine! [
 72		hFile 					[integer!]
 73		lpBuffer				[string!]
 74		nNumberOfBytesToWrite   [integer!]
 75		lpNumberOfBytesWritten  [struct! [num [integer!]]]
 76		lpOverlapped			[integer!]
 77		return:					[integer!]
 78	] kernel32 "WriteFile"
 79	
 80	SetHandleInformation: make routine! [
 81		hObject 	[integer!]
 82		dwMask		[integer!]
 83		dwFlags		[integer!]
 84		return: 	[integer!]
 85	] kernel32 "SetHandleInformation"
 86	
 87	GetEnvironmentStrings: make routine! [
 88		return: [integer!]
 89	] kernel32 "GetEnvironmentStringsA"
 90	
 91	unless all [value? 'set-env native? :set-env][
 92		set 'set-env make routine! [
 93			name	[string!]
 94			value	[string!]
 95			return: [integer!]
 96		] kernel32 "SetEnvironmentVariableA"
 97	]
 98
 99	CreateProcess: make routine! compose/deep [
100		lpApplicationName	 [integer!]
101		lpCommandLine		 [string!]	
102		lpProcessAttributes	 [struct! [a [integer!] b [integer!] c [integer!]]]
103		lpThreadAttributes	 [struct! [a [integer!] b [integer!] c [integer!]]]
104		bInheritHandles		 [char!]
105		dwCreationFlags		 [integer!]
106		lpEnvironment		 [integer!]
107		lpCurrentDirectory	 [integer!]
108		lpStartupInfo		 [struct! [(startup-info-struct)]]
109		lpProcessInformation [struct! [a [integer!] b [integer!] c [integer!] d [integer!]]]
110		return:				 [integer!]
111	] kernel32 "CreateProcessA"
112
113	CloseHandle: make routine! [
114		hObject	[integer!]
115		return: [integer!]
116	] kernel32 "CloseHandle"
117
118	GetExitCodeProcess: make routine! [
119		hProcess	[integer!]
120		lpExitCode	[struct! [int [integer!]]] 
121		return:		[integer!]
122	] kernel32 "GetExitCodeProcess"
123	
124	Sleep: make routine! [
125	  dwMilliseconds [long]
126	] kernel32 "Sleep"
127	
128	FORMAT_MESSAGE_FROM_SYSTEM:	   to-integer #{00001000}
129	FORMAT_MESSAGE_IGNORE_INSERTS: to-integer #{00000200}
130
131	fmt-msg-flags: FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_IGNORE_INSERTS
132	
133	GetLastError: make routine! [
134		return: [integer!]
135	] kernel32 "GetLastError"
136
137	FormatMessage: make routine! [
138		dwFlags		 [integer!]
139		lpSource	 [integer!]
140		dwMessageId  [integer!]
141		dwLanguageId [integer!]
142		lpBuffer	 [string!]
143		nSize		 [integer!]
144		Arguments	 [integer!]
145		return:		 [integer!]
146	] kernel32 "FormatMessageA"
147
148	STARTF_USESTDHANDLES: 	to-integer #{00000100}
149	STARTF_USESHOWWINDOW: 	1
150	SW_HIDE: 				0
151	STILL_ACTIVE:			259
152
153	null: to-char 0
154	lpDWORD: make struct! [int [integer!]] none
155	make-lpDWORD: does [make struct! lpDWORD [0]]
156	
157	sa: make struct! SECURITY_ATTRIBUTES [0 0 1]
158	sa/nLength: length? third sa
159	
160	start-info: make struct! STARTUPINFO none
161	start-info/cb: length? third start-info
162	start-info/dwFlags: STARTF_USESTDHANDLES
163	
164	make-null-string!: func [len [integer!]][
165		head insert/dup make string! len null len
166	]
167	
168	get-error-msg: has [out][
169		out: make-null-string! 256
170		FormatMessage fmt-msg-flags 0 last-error: GetLastError 0 out 256 0
171		trim/tail out
172	]
173	
174	try*: func [body [block!] /local out err][
175		if error? set/any 'err try body [
176			out: get-error-msg
177			err: disarm err
178			if string? get in err 'arg1 [insert out rejoin [err/arg1 ": "]]
179			return out
180		]
181		none
182	]
183	
184	cmd: context [
185		output: error: none
186		show?: input?: no
187
188		pipe-size: 10'000
189		pipe-buffer: make-null-string! pipe-size
190
191		si: make struct! start-info second start-info
192		pi: make struct! PROCESS_INFORMATION none
193
194		in-hRead:      make-lpDWORD
195		in-hWrite:     make-lpDWORD
196		out-hRead:     make-lpDWORD
197		out-hWrite:    make-lpDWORD
198		err-hRead:	   make-lpDWORD
199		err-hWrite:	   make-lpDWORD
200		bytes-avail:   make-lpDWORD
201		bytes-read:    make-lpDWORD
202		bytes-written: make-lpDWORD
203		exit-code:     make-lpDWORD
204	]
205
206	launch-call: func [cmd-line [string!] /local ret env][
207		cmd-line: join cmd-line null
208		change/dup cmd/pipe-buffer null cmd/pipe-size
209		
210		ret: catch [
211			;-- Create STDOUT pipe and ensure the read handle is not inherited
212			if zero? CreatePipe cmd/out-hRead cmd/out-hWrite sa 0 [throw 1]
213			if zero? SetHandleInformation cmd/out-hRead/int 1 0 [throw 3]
214			cmd/si/hStdOutput: cmd/out-hWrite/int
215			
216			;-- Create STDERR pipe and ensure the read handle is not inherited			
217			if zero? CreatePipe cmd/err-hRead cmd/err-hWrite sa 0 [throw 1]
218			if zero? SetHandleInformation cmd/err-hRead/int 1 0 [throw 3]
219			cmd/si/hStdError:  cmd/err-hWrite/int
220
221			if cmd/input? [
222				;-- Create STDIN pipe and ensure the write handle is not inherited
223				if zero? CreatePipe cmd/in-hRead cmd/in-hWrite sa 0 [throw 1]
224				if zero? SetHandleInformation cmd/in-hWrite/int 1 0 [throw 3]
225				cmd/si/hStdInput: cmd/in-hRead/int
226			]
227			
228			unless cmd/show? [cmd/si/dwFlags: cmd/si/dwFlags or STARTF_USESHOWWINDOW]			
229			env: GetEnvironmentStrings
230			
231			if zero? CreateProcess 0 cmd-line sa sa to char! 1 0 env 0 cmd/si cmd/pi [throw 2]
232			
233			ret: none
234		]
235		if integer? ret [
236			make error! join pick [
237				"CreatePipe"
238				"CreateProcess"
239				"SetHandleInformation"
240			] ret " failed!"
241		]
242	]
243	
244	read-pipe: func [buffer pipe /local remain][
245		if zero? PeekNamedPipe pipe/int 0 0 0 cmd/bytes-avail 0 [throw 1]
246
247		unless zero? remain: cmd/bytes-avail/int [ 
248			until [
249				if zero? ReadFile pipe/int cmd/pipe-buffer cmd/pipe-size cmd/bytes-read 0 [throw 2]
250
251				insert/part tail buffer cmd/pipe-buffer cmd/bytes-read/int
252
253				change/dup cmd/pipe-buffer null cmd/pipe-size
254				remain: remain - cmd/bytes-read/int 
255				zero? remain 
256			]
257		]
258	]
259	
260	write-pipe: func [buffer pipe][
261		until [
262			if zero? WriteFile pipe/int buffer length? buffer cmd/bytes-written 0 [throw 4]		
263			tail? buffer: skip buffer cmd/bytes-written/int
264		]
265		;-- Close the pipe handles so the child process stops reading
266		CloseHandle cmd/in-hRead/int
267		CloseHandle cmd/in-hWrite/int
268	]
269
270    get-process-info: has [ret][	
271		;unless zero? cmd/pi/hProcess [
272			ret: catch [
273				if zero? GetExitCodeProcess cmd/pi/hProcess cmd/exit-code [throw 3]
274 				
275				if cmd/output [read-pipe cmd/output cmd/out-hRead]
276				if cmd/error  [read-pipe cmd/error  cmd/err-hRead]
277				
278				if cmd/exit-code/int <> STILL_ACTIVE [
279					CloseHandle cmd/pi/hProcess
280					CloseHandle cmd/pi/hThread
281					CloseHandle cmd/out-hRead/int
282					CloseHandle cmd/out-hWrite/int
283					CloseHandle cmd/err-hRead/int
284					CloseHandle cmd/err-hWrite/int
285					cmd/pi/hProcess: 0
286					return true
287				]
288				ret: none
289			]
290			if integer? ret [
291				make error! join pick [
292					"PeekNamedPipe"
293					"ReadFile"
294					"GetExitCodeProcess"
295					"WriteFile"
296				] ret " failed!"
297			]
298		;]
299		false
300    ]
301
302	set 'win-call func [
303		command [string!]
304		/input
305			in [string! binary!]
306		/output
307			out [string! binary!]
308		/error
309			err [string! binary!]
310		/wait						;-- placeholder, win-call is always waiting
311		/show
312		/local
313			res msg
314	][
315		cmd/input?: to-logic input
316		cmd/show?: to-logic show
317		cmd/output: out
318		cmd/error: err
319		
320		if msg: try* [launch-call command][return msg]
321		if input [write-pipe in cmd/in-hWrite]
322		
323		until [
324			Sleep 10
325			if msg: try* [res: get-process-info][return msg]
326			res
327		]
328		none
329	]
330]