! Copyright (C) 2007, 2010 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types alien.data arrays assocs classes classes.struct combinators concurrency.flags continuations debugger destructors init io io.backend io.backend.windows io.files io.files.private io.files.windows io.launcher io.pathnames io.pipes io.pipes.windows io.ports kernel libc locals make math namespaces prettyprint sequences specialized-arrays splitting splitting.monotonic strings system threads windows windows.errors windows.handles windows.kernel32 windows.types combinators.short-circuit ; SPECIALIZED-ARRAY: ushort SPECIALIZED-ARRAY: void* IN: io.launcher.windows TUPLE: CreateProcess-args lpApplicationName lpCommandLine lpProcessAttributes lpThreadAttributes bInheritHandles dwCreateFlags lpEnvironment lpCurrentDirectory lpStartupInfo lpProcessInformation ; : default-CreateProcess-args ( -- obj ) CreateProcess-args new STARTUPINFO dup class-of heap-size >>cb >>lpStartupInfo PROCESS_INFORMATION >>lpProcessInformation TRUE >>bInheritHandles 0 >>dwCreateFlags ; : call-CreateProcess ( CreateProcess-args -- ) { [ lpApplicationName>> ] [ lpCommandLine>> ] [ lpProcessAttributes>> ] [ lpThreadAttributes>> ] [ bInheritHandles>> ] [ dwCreateFlags>> ] [ lpEnvironment>> ] [ lpCurrentDirectory>> ] [ lpStartupInfo>> ] [ lpProcessInformation>> ] } cleave CreateProcess win32-error=0/f ; : count-trailing-backslashes ( str n -- str n ) [ "\\" ?tail ] dip swap [ 1 + count-trailing-backslashes ] when ; : fix-trailing-backslashes ( str -- str' ) 0 count-trailing-backslashes 2 * CHAR: \\ append ; ! Find groups of \, groups of \ followed by ", or naked " : escape-double-quote ( str -- newstr ) [ { [ drop CHAR: \ = ] [ nip "\\\"" member? ] } 2&& ] monotonic-split [ dup last CHAR: " = [ dup length 1 > [ ! String of backslashes + double-quote length 1 - 2 * CHAR: \ "\\\"" append ] [ ! Single double-quote drop "\\\"" ] if ] when ] map "" concat-as ; ! Naked double-quotes get a backslash before them ! Backslashes before a double-quote get doubled in the output ! If there's a space, double trailing backslashes and surround by quotes ! See http://msdn.microsoft.com/en-us/library/ms647232.aspx : escape-argument ( str -- newstr ) escape-double-quote CHAR: \s over member? [ fix-trailing-backslashes "\"" dup surround ] when ; : join-arguments ( args -- cmd-line ) [ escape-argument ] map " " join ; : lookup-priority ( process -- n ) priority>> { { +lowest-priority+ [ IDLE_PRIORITY_CLASS ] } { +low-priority+ [ BELOW_NORMAL_PRIORITY_CLASS ] } { +normal-priority+ [ NORMAL_PRIORITY_CLASS ] } { +high-priority+ [ ABOVE_NORMAL_PRIORITY_CLASS ] } { +highest-priority+ [ HIGH_PRIORITY_CLASS ] } { +realtime-priority+ [ REALTIME_PRIORITY_CLASS ] } [ drop f ] } case ; : cmd-line ( process -- cmd-line ) command>> dup string? [ join-arguments ] unless ; : fill-lpCommandLine ( process args -- process args ) over cmd-line >>lpCommandLine ; : fill-dwCreateFlags ( process args -- process args ) 0 pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when pick detached>> os windows? and [ DETACHED_PROCESS bitor ] when pick lookup-priority [ bitor ] when* >>dwCreateFlags ; : fill-lpEnvironment ( process args -- process args ) over pass-environment? [ [ over get-environment [ swap % "=" % % "\0" % ] assoc-each "\0" % ] ushort-array{ } make >>lpEnvironment ] when ; : fill-startup-info ( process args -- process args ) dup lpStartupInfo>> STARTF_USESTDHANDLES >>dwFlags drop ; : make-CreateProcess-args ( process -- args ) default-CreateProcess-args fill-lpCommandLine fill-dwCreateFlags fill-lpEnvironment fill-startup-info nip ; M: windows current-process-handle ( -- handle ) GetCurrentProcessId ; ERROR: launch-error process error ; M: launch-error error. "Launching failed with error:" print dup error>> error. nl "Launch descriptor:" print nl process>> . ; M: windows kill-process* ( process -- ) handle>> hProcess>> 255 TerminateProcess win32-error=0/f ; : dispose-process ( process-information -- ) #! From MSDN: "Handles in PROCESS_INFORMATION must be closed #! with CloseHandle when they are no longer needed." [ hProcess>> [ CloseHandle drop ] when* ] [ hThread>> [ CloseHandle drop ] when* ] bi ; : exit-code ( process -- n ) hProcess>> { DWORD } [ GetExitCodeProcess ] with-out-parameters swap win32-error=0/f ; : process-exited ( process -- ) dup handle>> exit-code over handle>> dispose-process notify-exit ; M: windows wait-for-processes ( -- ? ) processes get keys dup [ handle>> hProcess>> ] void*-array{ } map-as [ length ] keep 0 0 WaitForMultipleObjects dup 0xffffffff = [ win32-error ] when dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ; : duplicate-handle ( handle -- handle' ) GetCurrentProcess ! source process swap handle>> ! handle GetCurrentProcess ! target process f void* [ ! target handle DUPLICATE_SAME_ACCESS ! desired access TRUE ! inherit handle 0 ! options DuplicateHandle win32-error=0/f ] keep void* deref &dispose ; ! /dev/null simulation : null-input ( -- pipe ) (pipe) [ in>> &dispose ] [ out>> dispose ] bi ; : null-output ( -- pipe ) (pipe) [ out>> &dispose ] [ in>> dispose ] bi ; : null-pipe ( mode -- pipe ) { { GENERIC_READ [ null-input ] } { GENERIC_WRITE [ null-output ] } } case ; ! The below code is based on the example given in ! http://msdn2.microsoft.com/en-us/library/ms682499.aspx : redirect-default ( obj access-mode create-mode -- handle ) 3drop f ; : redirect-closed ( obj access-mode create-mode -- handle ) drop nip null-pipe ; :: redirect-file ( path access-mode create-mode -- handle ) path normalize-path access-mode share-mode default-security-attributes create-mode FILE_ATTRIBUTE_NORMAL ! flags and attributes f ! template file CreateFile check-invalid-handle &dispose ; : redirect-append ( path access-mode create-mode -- handle ) [ path>> ] 2dip drop OPEN_ALWAYS redirect-file dup 0 FILE_END set-file-pointer ; : redirect-handle ( handle access-mode create-mode -- handle ) 2drop ; : redirect-stream ( stream access-mode create-mode -- handle ) [ underlying-handle ] 2dip redirect-handle ; : redirect ( obj access-mode create-mode -- handle ) { { [ pick not ] [ redirect-default ] } { [ pick +closed+ eq? ] [ redirect-closed ] } { [ pick string? ] [ redirect-file ] } { [ pick appender? ] [ redirect-append ] } { [ pick win32-file? ] [ redirect-handle ] } [ redirect-stream ] } cond dup [ dup t set-inherit handle>> ] when ; : redirect-stdout ( process args -- handle ) drop stdout>> GENERIC_WRITE CREATE_ALWAYS redirect STD_OUTPUT_HANDLE GetStdHandle or ; : redirect-stderr ( process args -- handle ) over stderr>> +stdout+ eq? [ nip lpStartupInfo>> hStdOutput>> ] [ drop stderr>> GENERIC_WRITE CREATE_ALWAYS redirect STD_ERROR_HANDLE GetStdHandle or ] if ; : redirect-stdin ( process args -- handle ) drop stdin>> GENERIC_READ OPEN_EXISTING redirect STD_INPUT_HANDLE GetStdHandle or ; : fill-redirection ( process args -- ) dup lpStartupInfo>> [ [ redirect-stdout ] dip hStdOutput<< ] [ [ redirect-stderr ] dip hStdError<< ] [ [ redirect-stdin ] dip hStdInput<< ] 3tri ; M: windows run-process* ( process -- handle ) [ [ current-directory get absolute-path cd dup make-CreateProcess-args [ fill-redirection ] keep dup call-CreateProcess lpProcessInformation>> ] with-destructors ] [ launch-error ] recover ;