basis/io/windows/launcher/launcher.factor

   1 ! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: alien alien.c-types arrays continuations io
   4 io.windows io.windows.nt.pipes libc io.ports
   5 windows.types math windows.kernel32
   6 namespaces io.launcher kernel sequences windows.errors
   7 splitting system threads init strings combinators
   8 io.backend accessors concurrency.flags io.files assocs
   9 io.files.private windows destructors classes.tuple.lib ;
  10 IN: io.windows.launcher
  11
  12 TUPLE: CreateProcess-args
  13        lpApplicationName
  14        lpCommandLine
  15        lpProcessAttributes
  16        lpThreadAttributes
  17        bInheritHandles
  18        dwCreateFlags
  19        lpEnvironment
  20        lpCurrentDirectory
  21        lpStartupInfo
  22        lpProcessInformation ;
  23
  24 : default-CreateProcess-args ( -- obj )
  25     CreateProcess-args new
  26     "STARTUPINFO" <c-object>
  27     "STARTUPINFO" heap-size over set-STARTUPINFO-cb >>lpStartupInfo
  28     "PROCESS_INFORMATION" <c-object> >>lpProcessInformation
  29     TRUE >>bInheritHandles
  30     0 >>dwCreateFlags ;
  31
  32 : call-CreateProcess ( CreateProcess-args -- )
  33     CreateProcess-args >tuple< CreateProcess win32-error=0/f ;
  34
  35 : count-trailing-backslashes ( str n -- str n )
  36     >r "\\" ?tail [
  37         r> 1+ count-trailing-backslashes
  38     ] [
  39         r>
  40     ] if ;
  41
  42 : fix-trailing-backslashes ( str -- str' )
  43     0 count-trailing-backslashes
  44     2 * CHAR: \\ <repetition> append ;
  45
  46 : escape-argument ( str -- newstr )
  47     CHAR: \s over member? [
  48         "\"" swap fix-trailing-backslashes "\"" 3append
  49     ] when ;
  50
  51 : join-arguments ( args -- cmd-line )
  52     [ escape-argument ] map " " join ;
  53
  54 : lookup-priority ( process -- n )
  55     priority>> {
  56         { +lowest-priority+ [ IDLE_PRIORITY_CLASS ] }
  57         { +low-priority+ [ BELOW_NORMAL_PRIORITY_CLASS ] }
  58         { +normal-priority+ [ NORMAL_PRIORITY_CLASS ] }
  59         { +high-priority+ [ ABOVE_NORMAL_PRIORITY_CLASS ] }
  60         { +highest-priority+ [ HIGH_PRIORITY_CLASS ] }
  61         { +realtime-priority+ [ REALTIME_PRIORITY_CLASS ] }
  62         [ drop f ]
  63     } case ;
  64
  65 : app-name/cmd-line ( process -- app-name cmd-line )
  66     command>> dup string? [
  67         " " split1
  68     ] [
  69         unclip swap join-arguments
  70     ] if ;
  71
  72 : cmd-line ( process -- cmd-line )
  73     command>> dup string? [ join-arguments ] unless ;
  74
  75 : fill-lpApplicationName ( process args -- process args )
  76     over app-name/cmd-line
  77     >r >>lpApplicationName
  78     r> >>lpCommandLine ;
  79
  80 : fill-lpCommandLine ( process args -- process args )
  81     over cmd-line >>lpCommandLine ;
  82
  83 : fill-dwCreateFlags ( process args -- process args )
  84     0
  85     pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
  86     pick detached>> os winnt? and [ DETACHED_PROCESS bitor ] when
  87     pick lookup-priority [ bitor ] when*
  88     >>dwCreateFlags ;
  89
  90 : fill-lpEnvironment ( process args -- process args )
  91     over pass-environment? [
  92         [
  93             over get-environment
  94             [ swap % "=" % % "\0" % ] assoc-each
  95             "\0" %
  96         ] "" make >c-ushort-array
  97         >>lpEnvironment
  98     ] when ;
  99
 100 : fill-startup-info ( process args -- process args )
 101     STARTF_USESTDHANDLES over lpStartupInfo>> set-STARTUPINFO-dwFlags ;
 102
 103 HOOK: fill-redirection io-backend ( process args -- )
 104
 105 M: wince fill-redirection 2drop ;
 106
 107 : make-CreateProcess-args ( process -- args )
 108     default-CreateProcess-args
 109     os wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
 110     fill-dwCreateFlags
 111     fill-lpEnvironment
 112     fill-startup-info
 113     nip ;
 114
 115 M: windows current-process-handle ( -- handle )
 116     GetCurrentProcessId ;
 117
 118 M: windows run-process* ( process -- handle )
 119     [
 120         current-directory get (normalize-path) cd
 121
 122         dup make-CreateProcess-args
 123         tuck fill-redirection
 124         dup call-CreateProcess
 125         lpProcessInformation>>
 126     ] with-destructors ;
 127
 128 M: windows kill-process* ( handle -- )
 129     PROCESS_INFORMATION-hProcess
 130     255 TerminateProcess win32-error=0/f ;
 131
 132 : dispose-process ( process-information -- )
 133     #! From MSDN: "Handles in PROCESS_INFORMATION must be closed
 134     #! with CloseHandle when they are no longer needed."
 135     dup PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when*
 136     PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ;
 137
 138 : exit-code ( process -- n )
 139     PROCESS_INFORMATION-hProcess
 140     0 <ulong> [ GetExitCodeProcess ] keep *ulong
 141     swap win32-error=0/f ;
 142
 143 : process-exited ( process -- )
 144     dup process-handle exit-code
 145     over process-handle dispose-process
 146     notify-exit ;
 147
 148 M: windows wait-for-processes ( -- ? )
 149     processes get keys dup
 150     [ process-handle PROCESS_INFORMATION-hProcess ] map
 151     dup length swap >c-void*-array 0 0
 152     WaitForMultipleObjects
 153     dup HEX: ffffffff = [ win32-error ] when
 154     dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;