/quick-test/call.r
R | 330 lines | 282 code | 48 blank | 0 comment | 24 complexity | 4e8a4b1a3fda465430e3f73bbffbf08a MD5 | raw file
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]