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 make 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 ;
  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     {
  34         [ lpApplicationName>> ]
  35         [ lpCommandLine>> ]
  36         [ lpProcessAttributes>> ]
  37         [ lpThreadAttributes>> ]
  38         [ bInheritHandles>> ]
  39         [ dwCreateFlags>> ]
  40         [ lpEnvironment>> ]
  41         [ lpCurrentDirectory>> ]
  42         [ lpStartupInfo>> ]
  43         [ lpProcessInformation>> ]
  44     } cleave
  45     CreateProcess win32-error=0/f ;
  46
  47 : count-trailing-backslashes ( str n -- str n )
  48     >r "\\" ?tail r> swap [
  49         1+ count-trailing-backslashes
  50     ] when ;
  51
  52 : fix-trailing-backslashes ( str -- str' )
  53     0 count-trailing-backslashes
  54     2 * CHAR: \\ <repetition> append ;
  55
  56 : escape-argument ( str -- newstr )
  57     CHAR: \s over member? [
  58         "\"" swap fix-trailing-backslashes "\"" 3append
  59     ] when ;
  60
  61 : join-arguments ( args -- cmd-line )
  62     [ escape-argument ] map " " join ;
  63
  64 : lookup-priority ( process -- n )
  65     priority>> {
  66         { +lowest-priority+ [ IDLE_PRIORITY_CLASS ] }
  67         { +low-priority+ [ BELOW_NORMAL_PRIORITY_CLASS ] }
  68         { +normal-priority+ [ NORMAL_PRIORITY_CLASS ] }
  69         { +high-priority+ [ ABOVE_NORMAL_PRIORITY_CLASS ] }
  70         { +highest-priority+ [ HIGH_PRIORITY_CLASS ] }
  71         { +realtime-priority+ [ REALTIME_PRIORITY_CLASS ] }
  72         [ drop f ]
  73     } case ;
  74
  75 : app-name/cmd-line ( process -- app-name cmd-line )
  76     command>> dup string? [
  77         " " split1
  78     ] [
  79         unclip swap join-arguments
  80     ] if ;
  81
  82 : cmd-line ( process -- cmd-line )
  83     command>> dup string? [ join-arguments ] unless ;
  84
  85 : fill-lpApplicationName ( process args -- process args )
  86     over app-name/cmd-line
  87     >r >>lpApplicationName
  88     r> >>lpCommandLine ;
  89
  90 : fill-lpCommandLine ( process args -- process args )
  91     over cmd-line >>lpCommandLine ;
  92
  93 : fill-dwCreateFlags ( process args -- process args )
  94     0
  95     pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
  96     pick detached>> os winnt? and [ DETACHED_PROCESS bitor ] when
  97     pick lookup-priority [ bitor ] when*
  98     >>dwCreateFlags ;
  99
 100 : fill-lpEnvironment ( process args -- process args )
 101     over pass-environment? [
 102         [
 103             over get-environment
 104             [ swap % "=" % % "\0" % ] assoc-each
 105             "\0" %
 106         ] "" make >c-ushort-array
 107         >>lpEnvironment
 108     ] when ;
 109
 110 : fill-startup-info ( process args -- process args )
 111     STARTF_USESTDHANDLES over lpStartupInfo>> set-STARTUPINFO-dwFlags ;
 112
 113 HOOK: fill-redirection io-backend ( process args -- )
 114
 115 M: wince fill-redirection 2drop ;
 116
 117 : make-CreateProcess-args ( process -- args )
 118     default-CreateProcess-args
 119     os wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
 120     fill-dwCreateFlags
 121     fill-lpEnvironment
 122     fill-startup-info
 123     nip ;
 124
 125 M: windows current-process-handle ( -- handle )
 126     GetCurrentProcessId ;
 127
 128 M: windows run-process* ( process -- handle )
 129     [
 130         current-directory get (normalize-path) cd
 131
 132         dup make-CreateProcess-args
 133         tuck fill-redirection
 134         dup call-CreateProcess
 135         lpProcessInformation>>
 136     ] with-destructors ;
 137
 138 M: windows kill-process* ( handle -- )
 139     PROCESS_INFORMATION-hProcess
 140     255 TerminateProcess win32-error=0/f ;
 141
 142 : dispose-process ( process-information -- )
 143     #! From MSDN: "Handles in PROCESS_INFORMATION must be closed
 144     #! with CloseHandle when they are no longer needed."
 145     dup PROCESS_INFORMATION-hProcess [ CloseHandle drop ] when*
 146     PROCESS_INFORMATION-hThread [ CloseHandle drop ] when* ;
 147
 148 : exit-code ( process -- n )
 149     PROCESS_INFORMATION-hProcess
 150     0 <ulong> [ GetExitCodeProcess ] keep *ulong
 151     swap win32-error=0/f ;
 152
 153 : process-exited ( process -- )
 154     dup handle>> exit-code
 155     over handle>> dispose-process
 156     notify-exit ;
 157
 158 M: windows wait-for-processes ( -- ? )
 159     processes get keys dup
 160     [ handle>> PROCESS_INFORMATION-hProcess ] map
 161     dup length swap >c-void*-array 0 0
 162     WaitForMultipleObjects
 163     dup HEX: ffffffff = [ win32-error ] when
 164     dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ;