basis/io/launcher/windows/windows.factor

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