factor/basis/io/launcher/windows/windows.factor

! 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.launcher.private 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 <struct>
        dup class-of heap-size >>cb
    >>lpStartupInfo
    PROCESS_INFORMATION <struct> >>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: \\ <repetition> 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: \ <repetition> "\\\"" 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 )
    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* <ref> [ ! target handle
        DUPLICATE_SAME_ACCESS ! desired access
        TRUE ! inherit handle
        0 ! options
        DuplicateHandle win32-error=0/f
    ] keep void* deref <win32-handle> &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 <win32-file> &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 )
    [
        [
            dup make-CreateProcess-args
            current-directory get absolute-path >>lpCurrentDirectory
            [ fill-redirection ] keep
            dup call-CreateProcess
            lpProcessInformation>>
        ] with-destructors
    ] [ throw-launch-error ] recover ;